home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1994 / MacHack 1994.toast / MacHack™94 / Talks & Papers / Timothy Knox / yerk 3.66 / nuc / yerk3.66.txt < prev   
Text File  |  1994-06-24  |  80KB  |  3,625 lines
  1. ; System 7 modifications
  2. ; courier 9pt -9 spacing tabs: .875 1.5 3.625
  3. ; need to change modification in vers RSRC
  4. ; flush caches in trap; fix d0 saves for flushes
  5. ; fixed s,; added ucase in word_
  6. ; 3.66=3.64
  7. ;    Load equates for Toolbox, Quickdraw
  8.     LIST OFF
  9.     INCLUDE    "library.asm"
  10.     INCLUDE    "equates.asm"
  11.     INCLUDE    "yerk.macro"
  12. *
  13. gestalt    EQU    $a1ad
  14. newhandc    EQU    $a322
  15. newPtrc    EQU    $a31e
  16. stripAddress    EQU    $a055
  17. waitNextEvt    EQU    $a860
  18. HWPriv    EQU    $a198
  19.     GLOBAL    $200,$200
  20.     ENDG
  21.     TFILE "YERK.BIN"
  22.     RFILE "YERK",APPL,YERK,$2100    ; has bundle,init
  23. ;
  24. Rsize    EQU    400    ; Maximum depth of ret+mstack
  25. Rbytes    EQU    -Rsize*4    ; Number of bytes for ret+mstack
  26. MSbytes    EQU    1200    ; 300 cells on methods stack
  27. sysVects    EQU    17    ; how many system vectors + 1 (for len)
  28. sysVecSz    EQU    sysVects*4    ; total len of system vector table
  29. ; 'SAVE' HEADER EQUATES.
  30. udp    EQU    0    ; User dictionary pointer
  31. ufence    EQU    4    ; User fence pointer
  32. uvocl    EQU    8    ; User vocabulary pointer
  33. ulatest    EQU    12    ; Latest NFA.
  34. headlen    EQU    16    ; Length of header
  35. ; Finder Handle Offsets
  36. opflag    EQU    0    ; Open/Print flag
  37. numfiles    EQU    2    ; Number of files
  38. volrnum    EQU    0    ; Volume reference number
  39. ftype    EQU    2    ; File type
  40. fvernum    EQU    6    ; File's version number
  41. fname    EQU    8    ; File name ( <count> <name> )
  42. f.handle    EQU    16    ; Offset to finder handle
  43. *
  44.     SEG    1,48
  45.     bra.s    start
  46. installed    data    /0    ; 0 if cold; 1 if warm; 2 if application
  47. getInstL    lea    installed(PC),a2    ; get Installed address in a2
  48.     rts
  49. start
  50.     lea    installed(PC),a2    ; see if this is a reboot
  51.     btst    #0,(a2)    ; if true, mem already acquired,
  52.     bne.s    already    ; skip initialization code
  53.     sjsr    getDict    ; load seg & get user dict size in d1
  54.     clr.l    -(sp)
  55.     move.l    #$434F4445,-(sp)    ; CODE
  56.     move.w    #2,-(sp)
  57.     _getResource
  58.     move.l    (sp),a0    ; keep handle on stack
  59.     clr.l    -(sp)    ; set up to get size of seg 2
  60.     move.l    a0,-(sp)
  61.     _SizeRsrc
  62.     move.l    (sp)+,d2    ; got size in d2
  63.     move.l    (sp),a0    ; recover handle
  64.     _Hunlock
  65.  
  66.     btst    #1,(a2)    ; if true, this is application
  67.     bne.s    isApp    ; don't change code size
  68.  
  69.     add.l    d2,d1    ; add nucleus length
  70. isApp    move.l    d1,d0
  71.     _SetHandleSize
  72.     tst.l    d0    ; did we get it?
  73.     beq.s    gotit
  74.     move.w    #3,-(sp)
  75.     _sysbeep
  76.     _exitToShell
  77. gotit
  78.     move.l    (sp)+,a0
  79.     _Hlock
  80.     lea    installed(PC),a0
  81.     ori.b    #1,(a0)    ; set true for installed
  82.     sjmp    origin
  83. already
  84.     sjmp    coldvec
  85.     ENDR
  86. *
  87.     SEG    2,48
  88. ;        begin USER initialization data
  89. origin    bra    ftInit    ; branch around initialization da
  90. one    EQU    origin
  91. segStart    EQU    origin-4
  92. lkorigin    EQU    origin    ; null link for first entry
  93. yerkID    ASC    "3640"    ; Release, version, revision, 0
  94.     ADJST
  95. initLast    DATA    Lastdef-origin    ; origin + 8: last definition addr
  96. initFenc    DATA    Lastdef-origin    ; fence
  97. initS0    DATA    0    ; offset from A3 for initial A7 (SP)
  98. initR0    DATA    0    ; offset from A3 for initial A6
  99. initmp    DATA    0    ; offset from A3 for initial D5
  100. initDP    DATA    0    ; DP - starts past sys vector table
  101. initVocl    DATA    0    ; VOC-LINK - last COLD init
  102. Userror    DATA    0    ; Error during load
  103. memsize    DATA    300000    ; user dictionary size for CODE2
  104. memPtr    DATA    0    ; abs ptr to the user dict heap
  105. userdp    DATA    0    ; Pointer to the user dict heap
  106. stksize    DATA    $ffffdcd8    ; 9000 stack size
  107. ;
  108. ;    End USER initialization data
  109. ;
  110. ftInit
  111.     link    a6,#rbytes    ; a6=R0,a7=S0 return stack
  112.     pea    -4(a5)
  113.     _InitGraf    ; initGraf(@thePort)
  114.     lea    origin(PC),a3    ; a3 -> code base at load
  115.     lea    stksize(PC),a0
  116.     move.l    (a0),d1
  117.     lea    0(a7,d1.l),a0    ; leave stack space
  118.     _setApplLimit
  119.     _MaxApplZone
  120.     _maxMem        ; force purge of the heap
  121. *
  122.     sjsr    getInstL    ; see if this is a reboot-from seg0
  123.     btst    #1,(a2)    ; if true, this is a program, so skip next
  124.     bne.s    noload
  125.     jsr    loaduser(PC)    ; load application dictionary if any
  126. noload    moveq    #(initS0-origin),d7    ; put offset into D7
  127.     move.l    SP,d0    ; store SP in d0
  128.     sub.l    a3,d0    ; reference to yerk base
  129.     move.l    d0,0(a3,d7.l)    ; inits0 now has offset to data stk
  130.     move.l    a6,d0    ; A6 points to methods stack
  131.     sub.l    a3,d0    ; reference to yerk base
  132.     lea    initmp(PC),a2    ; Init methods stack for cold load
  133.     move.l    d0,(a2)    ; initmp now has mstack offset
  134.     subi.l    #msbytes,d0    ; Leave 300 cells for M stack
  135.     move.l    d0,4(a3,d7.l)    ; initr0 now has offset to ret stk
  136. *
  137. COLDVEC    bra.s    ECLD    ; jump to cold start
  138. WARMVEC    bra.s    EWRM    ; jump to warm start
  139. ; =======Inner Interpreter ===========
  140. donext    move.l    (a4)+,d6    ; get next threaded instruction (32bit)
  141.     move.l    0(a3,d6.l),d7    ; get code address
  142.     jmp    0(a3,d7.l)    ; jump to code addr relative to a3
  143.     nop
  144. ECLD    movea.l    #applScratch,a2    ; fill scratch with warm start
  145.     move.w    #$4ef9,(a2)+    ; jmp
  146.     lea    ewrm(PC),a0
  147.     move.l    a0,(a2)    
  148. *
  149.     lea    cld1(PC),a4    ; A4 is IP in inner interpreter
  150.     bra.s    EWRM1
  151. EWRM    lea    warm1(PC),a4    ; A4 is IP in inner interpreter
  152. EWRM1    lea    origin(PC),a3
  153.     moveq    #(initS0-origin),d7    ; get address of initS0 in D7
  154.     movea.l    0(a3,d7.l),SP    ; pickup s0 address in SP
  155.     adda.l    a3,SP
  156.     movea.l    4(a3,d7.l),a6    ; pickup r0 address in a6
  157.     adda.l    a3,a6
  158.     move.l    initmp(PC),d5    ; Pick methods stack pointer
  159.     add.l    a3,d5
  160.     gonext
  161. ;
  162. ; GETDICT call from seg 0
  163. getDict    lea    memsize(PC),a1
  164.     move.l    (a1),d1
  165.     rts
  166. ;
  167. warm1    cfas    cls,abort,semis
  168. ; Loaduser routine loads the user dictionary if there is one to be loaded.
  169. ; First get some Heap to read the user dictionary into. We want
  170. ; get as much heap as there is available, minus some for the system.
  171. loaduser
  172.     lea    memsize(PC),a1    ; get initial space
  173.     move.l    (a1),d0
  174.     lea    nextdef+2(PC),a0    ; get top of nuc abs
  175.     sub.l    a0,d0    ; get user dict memsize acquired
  176.     add.l    a3,d0
  177. ;    move.l    d0,(a1)
  178.     asr.l    #2,d0           ; number of long words to clear
  179. clm    clr.l    (a0)+
  180.     dbra    d0,clm
  181.     lea    nextdef+2(PC),a0
  182.     lea    memptr(PC),a2
  183.     move.l    a0,(a2)    ; Save the memory pointer
  184. ; set up DP
  185.     suba.l    a3,a0    ; a0 has relative base of user dict
  186.     lea    initdp(PC),a2
  187.     move.l    a0,(a2)    ; Set default dp
  188.     andi.l    #$FFFFFF,(a2)    ; mask out hi byte  ????WHY
  189.     add.l    #sysvecSz,(a2)    ; bump dp past system vector table
  190. *
  191.     lea    userdp(PC),a2    ; Save pointer to dict. begin
  192.     move.l    a0,(a2)
  193.     andi.l    #$FFFFFF,(a2)
  194.     jsr    loadcom(PC)
  195.     rts
  196. ;
  197. ; Get the finder handle and see if there is file to be opened
  198. ;
  199. loadcom    movea.l    f.handle(a5),a0    ; Get finder handle
  200.     movea.l    (a0),a0    ; Dereference it
  201.     tst.w    (a0)    ; Check if open or print
  202.     beq    load010    ; ok to open
  203.     movea.l    #2,a0    ; error. we don't print
  204.     bra    loaderror
  205. ; The file is to be opened. See if there are any files to open.
  206. load010
  207.     tst.w    numfiles(a0)    ; any files to open?
  208.     bne    load020    ; at least one
  209.     movea.l    #1,a0    ; none. just the nucleus
  210.     bra    loaderror
  211. ; We have at least one file to be opened. Even if there are more than
  212. ; one at this point we are only going to open the first file picked.
  213. load020
  214.     adda.l    #4,a0    ; a0 points past the header
  215.     move.l    ftype(a0),a1    ; get filetype of the file
  216.     cmpa.l    #$434f4d20,a1    ; is it 'COM ' ?
  217.     bne    loaderror
  218.     lea    usefcb(PC),a1    ; load pointer to usefcb
  219.     lea    fname(a0),a2    ; load pointer to filename
  220.     move.l    a2,IoFileName(a1)    ; set file pointer in the fcb
  221.     lea    (a0),a2    ; load pointer to VRefNum
  222.     move.w    (a2),IoVRefNum(a1)    ; set VRefNum in the fcb
  223.     move.b    #1,IoPermssn(a1)    ; set i/o permission to readonly
  224.     move.l    a1,a0    ; Fcb in a0 for call
  225.     _open        ; Open the file
  226.     tst.w    IoResult(a0)    ; Check for errors
  227.     beq    load030    ; continue if ok
  228.     movea.l    IoResult(a0),a0    ; error code
  229.     bra    loaderror    ; Off to process errors
  230. ; Now get the file size so that we know how much to read in.
  231. load030    
  232.     movea.l    a1,a0    ; get the fcb back in a0
  233.     _getfileinfo    ; get info on the file
  234.     tst.w    IoResult(a0)    ; Check for errors
  235.     beq    load040    ; continue if ok
  236.     movea.l    IoResult(a0),a0    ; error code
  237.     bra    loaderror    ; Off to process errors
  238. load040
  239.     lea    nextdef+2(PC),a4    ; Get buffer addr
  240.     move.l    IoflLgLen(a0),d1    ; Get the logical length of file
  241.     movea.l    a1,a0    ; Fcb again
  242.     move.l    a4,iobuffer(a0)    ; Set buffer pointer for data in
  243.     move.l    #headlen,IoReqCount(a0)    ; Number of bytes to read
  244.     clr.l    IoPosMode(a0)    ; Read from beginning of file
  245.     clr.l    IoPosOffset(a0)    ; offset by 0
  246.     _read
  247.     tst.w    IoResult(a0)    ; Check for errors
  248.     beq    load060    ; continue if ok
  249.     movea.l    IoResult(a0),a0    ; error code
  250.     bra.s    loaderror    ; Off to process errors
  251. ; Initialize COLD load variables so that the user dictionary is included
  252. ; when the FORTH system is brought up.
  253. load060
  254.     lea    initdp(PC),a2
  255.     move.l    (a4),(a2)    ; Set dictionary pointer
  256.     lea    initfenc(PC),a2
  257.     move.l    ufence(a4),(a2)    ; Set fence pointer
  258.     lea    initvocl(PC),a2
  259.     move.l    uvocl(a4),(a2)    ; Set vocabulary link
  260.     lea    initLast(PC),a2
  261.     move.l    ulatest(a4),(a2)    ; Set latest NFA
  262. ; Now we can read the dictionary into the memory.
  263.     subi.l    #headlen,d1    ; Size of dictionary to read
  264.     move.l    d1,IoReqCount(a0)
  265.     clr.l    IoPosMode(a0)    ; Position to beginning of file
  266.     move.l    #headlen,IoPosOffset(a0)    ; Offset by headlen
  267.     _read        ; read the dictionary
  268.     tst.w    IoResult(a0)    ; Check for errors
  269.     beq    load070    ; continue if ok
  270.     movea.l    IoResult(a0),a0    ; error code
  271. loaderror
  272.     lea    userror(PC),a2
  273.     move.l    a0,(a2)    ; Save error code for cold
  274.     bra.s    load080
  275. load070
  276.     movea.l    a1,a0    ; fcb again
  277.     _close        ; Close the file
  278. load080
  279.     rts
  280. ; --------------------------------------
  281. ; area for calls to Toolbox, etc.
  282. ftwork    DEFS    20
  283. ftwork1    DC.L    0
  284. dsmsg    STR    "Parameter Stack:"
  285. rsmsg    STR    "Return Stack:   "
  286. msmsg    STR    "Methods Stack:  "
  287. emptymsg    STR    "  <empty>"
  288. pausemsg    STR    "Paused - <Space Bar> to continue>>>"
  289. bytesleft    STR    "Bytes Available: "
  290. hello    STR    "Macintosh Yerk Version 3.6.6"
  291.     ADJST
  292. tibbuf    DEFS    128    ; terminal input buffer
  293.     DATA    /0
  294.     DEFS    20    ; for numeric output
  295. padbuf    DEFS    256    ; text output buffer
  296. aregn    DATA    0    ; region handle for miscellany
  297.     ADJST
  298. ; Begin nucleus definitions
  299.     ADJST
  300. cld1    cfas    xcold,quit    ; do COLD word and enter Forth
  301. ; ====================================================
  302. ; Following are data areas that will be patched to look like objects
  303. ; after the Class/Object support code is in. Cfas will be patched to
  304. ; Class pointers.
  305. ; ====================================================
  306.     dcode    FWIND,x,origin,fwind ; link should be 0
  307. wRecord    
  308.     DEFS    windowsize    ; window record
  309.     DC.W    0,0,290,494    ; content rect boundaries
  310.     DC.W    8,8,340,510    ; grow rect boundaries
  311.     DC.W    -10000,-10000,10000,10000    ; drag rect boundaries
  312.     DC.W    1,1,1    ; growflg,dragflg, alive
  313.     DATA    nulw-origin    ; idle vector
  314.     DATA    cls-origin    ; deact vector
  315.     DATA    nulw-origin    ; content vector
  316.     DATA    nulw-origin    ; draw vector
  317.     DATA    nulw-origin    ; enact vector
  318.     DATA    nulw-origin    ; close vector
  319.     DC.W    $100    ; resid
  320.     DC.W    1    ; is this window scrollable?
  321.     DATA    0    ; special zoom cfa
  322.     dcode    FEVENT,x,fwind,fevent
  323. eventRec    DC.W    0    ; event record for GetNextEvent
  324. eventMsg    DC.L    0,0,0
  325. eventMod    DC.W    0
  326. eventmsk    DC.W    0
  327. eventSlp    DC.L    0
  328. mousRgn    DC.L    0
  329.     DC.W    4,23 ; header for event indexed area
  330.     DEFS    4*23
  331.     dcode    FFCB,x,fevent,ffcb
  332. ; ------------- Default FCB ------------
  333. useFCB    DEFS    144    ; Parm block for USING file
  334. useFname    DEFS    64    ; holds USING volume/file name string
  335. ; -----------------------------------------
  336. fcbl    EQU    *-useFCB    ; length of FCB
  337.     dcode    FPRECT,x,ffcb,fprect
  338. pRect    DC.W    0,0,294,470    ; Forth window rectangle
  339. ; =============================================================
  340.     dcode    ADOC,x,fprect,adoc
  341.     jsr    loadcom(PC)    ; load user dict according to fInfo
  342.     gonext
  343. ; system values
  344.     dval    S0,adoc,s0,0
  345.     dval    R0,S0,r0,0
  346.     dval    TIB,r0,tib,tibbuf-origin
  347.     dval    WARNING,tib,warn,1
  348.     dval    FENCE,warn,fence,0
  349.     dval    DP,fence,dp,0
  350.     dval    VOC-LINK,dp,vocl,0
  351.     dval    IN,vocl,in,0
  352.     dval    OUT,in,out,0
  353.     dval    CONTEXT,out,contxt,0
  354.     dval    CURRENT,contxt,currnt,0
  355.     dval    STATE,currnt,state,0
  356.     dval    CSTATE,state,cstate,0
  357.     dval    BASE,cstate,base,10
  358.     dval    DPL,base,dpl,0
  359.     dval    CSP,dpl,csp,0
  360.     dval    HLD,csp,hld,0
  361.     dval    WNEAVAIL,hld,wneavail,0    ; true if waitNextEvent in ROM
  362.     dval    HWPAVAIL,wneavail,hwpavail,0    ; true if flush cache
  363.     dval    HASGESTALT,hwpavail,hasGestalt,0    ; true if gestalt is in system
  364.     dval    HEAPTOP,hasGestalt,heapTop,0    ; top of heap filled at start
  365.     dval    HEAPBOT,heapTop,heapBot,0    ; bottom of heap filled at start
  366.     dval    UCASE,heapBot,ucase,1    ; flag for lowercase interpreting
  367.     dval    DOCS,ucase,docs,0    ; flag for document sources loaded
  368.     dval    LINE#,docs,line_,-1    ; line# in source file for documenation
  369.     dvect    VMODEL,line_,vmodel,nulw    ; model for other vectors
  370.     dcon    FILEMK,vmodel,filemk,-300+origin    ; file mark constant
  371.     dcon    NEXT,filemk,next,donext
  372.     dcon    BEGIN-DP,next,bdp,userdp    ; use @
  373.     dcon    LOAD-ERROR,bdp,lerror,Userror    ; use @
  374.     dval    M0,lerror,m0,0
  375.     dcon    USE-FCB,m0,ufcb,useFCB    ; pushes addr of useFCB
  376.     dcon    MSIZE,ufcb,msiz,memsize    ; use @
  377.     dcon    BL,msiz,bl,$20+origin
  378.     dcon    TRUE,bl,true,1+origin
  379.     dcon    FALSE,true,false,0+origin
  380.     dsvect    KEYVEC,false,keyvec,4,key_    ; system vectors for I/O
  381.     dsvect    EMITVEC,keyvec,emitvec,8,emit_    ; console emit
  382.     dsvect    PEMITVEC,emitvec,pemitv,12,drop    ; printer emit
  383.     dsvect    TYPEVEC,pemitv,typevec,16,type_    ; console type
  384.     dsvect    PTYPEVEC,typevec,ptypev,20,drop2
  385.     dsvect    EXPVEC,ptypev,expvec,24,expect    ; expect
  386.     dsvect    ECHOVEC,expvec,echovec,28,emit_    ; echo for keys
  387.     dsvect    ABORTVEC,echovec,abvec,32,nulw    ; installable abo
  388.     dsvect    QUITVEC,abvec,quvec,36,nulw    ; installable startup vector
  389.     dsvect    UFIND,quvec,ufind,40,false    ; vector for user find
  390.     dsvect    OBJINIT,ufind,objini,44,nulw    ; init nucleus objs
  391.     dsvect    PCRVEC,objini,pcrvec,48,nulw    ; printer CR
  392.     dsvect    BLDVEC,pcrvec,bldvec,52,nulw    ; object builder
  393.     dsvect    CREATE,bldvec,kreate,56,creat_    ; create vector
  394.     dsvect    INTERPRET,kreate,interp,60,intrp_
  395.     dsvect    CRVEC,interp,crvec,64,cr_
  396.     dval    DISK-ERROR,crvec,dkerr,0
  397.     dval    CURS,dkerr,curs_,1    ; cursor on/off flag
  398. crsflag    EQU    *-4
  399.     dval    UCFLAG,curs_,ucflag,1    ; map to upper case
  400. ; ==============================================
  401.     dcode    BYE,x,ucflag,bye_
  402.     _exitToShell
  403. *
  404.     dcode    (CODEZONE),x,bye_,instal
  405.     lea    segStart(PC),a1    ; set CODE 2 resource size
  406.     movea.l    a1,a0
  407.     _recoverHandle    ; get a handle to appl *** need to unlock
  408.     move.l    (a7)+,d0    ; get ending rel addr
  409.     addq.l    #1,d0
  410.     andi.l    #-2,d0    ; ensure even
  411.     addi.l    #4,d0    ; add CODE pointer length
  412.     _SetHandleSize    ; increase the size
  413.     gonext
  414. *
  415.     dcode    FINFO,x,instal,finfo    ; point to finder handle
  416.     movea.l    f.handle(a5),a0
  417.     movea.l    (a0),a0    ; dereference
  418.     suba.l    a3,a0    ; make relative
  419.     move.l    a0,-(SP)    ; push dereferenced ptr
  420.     gonext
  421. *
  422.     dcode    .CUR,x,finfo,dotcur    ; draw a cursor
  423.     jsr    pcurs(PC)
  424.     gonext
  425. *
  426. pcurs    lea    crsflag(PC),a0    ; ( -- )
  427.     tst.l    (a0)    ; is cursor on or off?
  428.     beq    nocurs
  429.     pea    ftwork(PC)
  430.     _GetPenState    ; get the current pen state
  431.     move.w    #10,-(SP)    ; set xor mode
  432.     _PenMode
  433.     move.w    #7,-(SP)
  434.     clr.w    -(SP)
  435.     _Line
  436.     pea    ftwork(PC)
  437.     _SetPenState
  438. nocurs    rts
  439. *
  440.     dcode    (EMIT),x,dotcur,emit_
  441.     jsr    pcurs(PC)
  442.     addq.l    #2,SP    ; long -> integer
  443.     _DrawChar    ; expects Pascal CHAR on stack
  444.     jsr    pcurs(PC)
  445.     gonext
  446. *
  447.     dcode    (TYPE),x,emit_,type_
  448.     move.l    a3,d0
  449.     add.l    d0,4(SP)    ; make address absolute
  450.     clr.l    d0
  451.     move.w    2(SP),d0
  452.     swap    d0
  453.     move.l    d0,(SP)    ; zero start byte offset
  454.     _DrawText
  455.     jsr    pcurs(PC)
  456.     gonext
  457. *
  458.     dcode    NULW,x,type_,nulw    ; empty word for stubbing vectors
  459.     gonext
  460. *
  461.     dcode    WORD0,x,nulw,word0    ; push a word of 0 for function setup
  462.     clr.w    -(SP)
  463.     gonext
  464. *
  465.     dcode    PACK,x,word0,pack_    ; packs 2 longs into one
  466.     popd0        ; get y
  467.     addq.l    #2,SP
  468.     move.w    d0,-(SP)
  469.     gonext
  470. *
  471.     dcode    UNPACK,x,pack_,unpack
  472.     move.l    (sp),d0
  473.     move.w    d0,d1
  474.     ext.l    d1
  475.     move.l    d1,(SP)
  476.     asr.l    #8,d0
  477.     asr.l    #8,d0
  478.     move.l    d0,-(SP)
  479.     gonext
  480. *
  481.     dcode    I->L,x,unpack,itol    ; extend 16 bit stack cell to 32
  482.     move.w    (sp)+,d0
  483.     ext.l    d0
  484.     move.l    d0,-(SP)
  485.     gonext
  486. *
  487.     dcode    MAKEINT,x,itol,makint
  488.     addq.l    #2,SP    ; drop high-level word on stack
  489.     gonext
  490. *
  491.     dcode    NEWPTR,x,makint,xnewpt
  492.     popd0        ; get size for new block in d0
  493.     _NewPtrC    ; call the memory manager for a new block
  494.     sub.l    a3,a0    ; make ptr relative
  495.     move.l    a0,-(SP)    ; push ptr to nonrelocatable block
  496.     gonext
  497. *
  498.     dcode    NEWHANDLE,x,xnewpt,xnewha
  499.     popd0
  500.     _newHandC    ; special vers of _NewHandle
  501.     move.l    a0,-(SP)    ; push handle to relocatable block
  502.     gonext
  503. *
  504. *    ( hndl -- b)
  505.     dcode    ?ISHANDLE,x,xnewha,ishand
  506.     movea.l    (sp),a0    ; get hndl
  507.     move.l    a0,d0    ; make copy for compares
  508.     btst    #0,d0    ; not hndl if odd
  509.     bne.s    no
  510.  
  511.     sub.l    a3,d0    ; into yerk mem space
  512.     cmp.l    heapBot9-origin(a3),d0    ; is hndl in prgm heap
  513.     blt.s    no    ; not hndl if < bot
  514.  
  515.     cmp.l    heapTop9-origin(a3),d0
  516.     bgt.s    no    ; not hndl if > top
  517.  
  518.     move.l    (a0),d0    ; get pointer
  519.     btst    #0,d0    ; not hndl if ptr odd
  520.     bne.s    no
  521.  
  522.     move.l    d0,d1    ; save ptr copy
  523.     sub.l    a3,d1    ; into yerk mem space
  524.     cmp.l    heapBot9-origin(a3),d1    ; is ptr in prgm heap
  525.     blt.s    no    ; not if < bot
  526.  
  527.     cmp.l    heapTop9-origin(a3),d1
  528.     bgt.s    no    ; not if > top
  529.  
  530.     movea.l    a0,a1    ; copy hndl
  531.     movea.l    d0,a0    ; move ptr into a0
  532.     _recoverHandle
  533.     cmp.l    a0,a1    ; are hndls equal
  534.     bne.s    no
  535.  
  536.     moveq    #1,d0    ; set true flag
  537.     bra.s    yes
  538.  
  539. no    moveq    #0,d0    ; set false flag
  540. yes    move.l    d0,(sp)
  541.     gonext
  542. *
  543.     dcode    LOCK,x,ishand,xlock
  544.     movea.l    (SP),a0    ; get handle in a0
  545.     _hLock        ; mark the block locked
  546.     movea.l    (SP),a0
  547.     movea.l    (a0),a1    ; dereference the handle
  548.     suba.l    a3,a1    ; make it a Forth address based on a3
  549.     move.l    a1,(SP)    ; leave Forth address on stack
  550.     gonext
  551. *
  552.     dcode    KILLPTR,x,xlock,killpt    ; (relPtr -- )
  553.     movea.l    (SP)+,a0    ; get rel ptr in a0
  554.     add.l    a3,a0    ; make it absolute
  555.     _disposPtr    ; release it
  556.     gonext
  557. *
  558.     dcode    KILLHANDLE,x,killpt,killha
  559.     movea.l    (SP)+,a0    ; get handle
  560.     _disposHandle
  561.     gonext
  562. *    
  563.     dcode    GROWPTR,x,killha,groptr    ; ( bytes relptr --)
  564.     movea.l    (SP)+,a0    ; get rel ptr in a0
  565.     adda.l    a3,a0    ; make it absolute
  566.     move.l    a0,d4
  567.     _getPtrSize
  568.     add.l    (sp)+,d0    ; get new handle size
  569.     movea.l    d4,a0
  570.     _SetPtrSize    ; grow the block
  571.     gonext
  572. *
  573.     dcode    FREE,x,groPtr,free_    ; ( -- maxAvail )
  574.     _freeMem        ; what is max mem avail on heap?
  575.     pushd0        ; includes purging
  576.     gonext
  577. *
  578.     dcode    FREEBLK,x,free_,freblk
  579.     _maxmem        ; what is max mem avail on heap?
  580.     pushd0        ; includes purging
  581.     gonext
  582. *
  583.     dcode    >PTR,x,freblk,fetptr    ; ( handle    --- relptr )
  584.     movea.l    (SP),a0
  585.     move.l    (a0),d0    ; dereference a handle
  586.     tst.b    wneavail9+3-origin(a3)    ; if wne, then stripaddr
  587.     beq.s    noStrip
  588.     _stripAddress
  589.     bra.s    onPtr
  590. noStrip    and.l  lo3bytes,d0
  591. onPtr    sub.l   a3,d0
  592.     move.l    d0,(SP)    ; return its pointer
  593.     gonext
  594. *
  595.     dcode    GET-EVENT,x,fetptr,getevt
  596.     move.l    (SP)+,d7    ; get event mask into d7
  597.     swap    d7
  598. ev1    move.l    d7,-(SP)    ; make room for function return
  599.     lea    eventRec(PC),a0 ; ptr to event rec storage
  600.     move.l    a0,-(sp)
  601.     tst.b    wneavail9+3-origin(a3)    ; is waitnextevent here?
  602.     beq.s    usegne0
  603.     move.l    18(a0),-(sp)    ; get sleep value
  604.     move.l    22(a0),-(sp)    ; get mouse rgn
  605.     _waitNextEvt
  606.     bra.s    endevt0
  607. usegne0    _SystemTask    ; WNE not in ROM
  608.     _GetNextEvent
  609. endevt0    tst.w    (SP)+    ; should we handle this event?
  610.     beq    ev1    ; no - get another one
  611.     lea    eventRec(PC),a0
  612.     clr.l    d0
  613.     move.w    (a0),d0    ; pick up event type
  614.     beq.s    ev1    ; loop if null event
  615.     pushd0        ; push event type for caller
  616.     gonext
  617. *
  618.     dcode    ?EVENT,x,getevt,qevt
  619.     move.l    (SP)+,d7    ; get event mask into d0
  620.     swap    d7
  621.     move.l    d7,-(SP)    ; make room for function return
  622.     pea    eventRec(PC)    ; pointer to event rec storage
  623.     _EventAvail    ; call Toolbox
  624.     tst.w    (SP)+    ; should we handle this event?
  625.     beq    event1    ; no - return false
  626.     lea    eventRec(PC),a0
  627.     clr.l    d0
  628.     move.w    (a0),d0    ; pick up event type
  629.     beq    event1    ; loop if null event
  630. event2    move.l    #1,-(SP)    ; push true - event available
  631.     bra.s    event3
  632. event1    clr.l    -(SP)    ; push false - no event available
  633. event3    gonext
  634. *
  635.     dcode    GETEVENT,x,qevt,gevt    ; (  --- b )
  636.     clr.w    -(sp)    ; make room for function return
  637.     lea    eventRec(PC),a0
  638.     move.w    eventMsk-eventRec(a0),-(sp)    ; get event mask
  639.     move.l    a0,-(sp)
  640.     tst.b    wneavail9+3-origin(a3)    ; is waitnextevent here?
  641.     beq.s    usegne
  642.     move.l    18(a0),-(sp)    ; get sleep value
  643.     move.l    22(a0),-(sp)    ; get mouse rgn
  644.     _waitNextEvt
  645.     bra.s    endevt
  646. usegne    _SystemTask    ; WNE not in ROM
  647.     _GetNextEvent
  648. endevt    clr.w    -(SP)    ; make an integer a long
  649.     gonext
  650. *
  651.     dcode    @EVENT-MSG,x,gevt,ftemsg
  652.     lea    eventMsg(PC),a0
  653.     move.l    (a0),-(SP)    ; push contents of last event msg
  654.     gonext
  655. *
  656. ; Flush the caches on 030,040 machines
  657.     dcode    CFLUSH,x,ftemsg,cflush
  658.     tst.b    hwpavail9+3-origin(a3)
  659.     beq.s    noflush
  660.     moveq    #1,d0
  661.     _HWPriv
  662. noflush    gonext
  663. *
  664. ; FIND-WINDOW ( point -- region, wptr )
  665.     dcode    FIND-WINDOW,x,cflush,findw
  666.     popd0
  667.     clr.w    -(SP)
  668.     pushd0
  669.     pea    ftwork1(PC)
  670.     _FindWindow
  671.     clr.w    -(SP)
  672.     lea    ftwork1(PC),a0
  673.     move.l    (a0),d0
  674.     sub.l    a3,d0
  675.     pushd0
  676.     gonext
  677. *
  678.     dcode    INIT-TOOLS,x,findw,intool
  679.     _InitFonts
  680.     move.l    #$ffff,d0    ; every event rfl 10/89
  681.     _FlushEvents
  682.     _InitWindows
  683.     _TEInit
  684.     pea    EWRM(PC)    ; warm start for Resume button
  685. ;in deep shit
  686.     _InitDialogs
  687.     clr.l    -(SP)    ; for windowPtr return
  688.     move.w    #256,-(SP)    ; window ID
  689.     pea    wrecord(PC)
  690.     move.l    #-1,-(SP)    ; POINTER(-1) for front window
  691.     _GetNewWindow    ; get window resource def
  692.     _setPort        ; setPort(WindowPtr)
  693.     lea    wrecord(PC),a0
  694.     move.w    #9,txSize(a0)    ; window text size = 9
  695.     move.w    #4,txfont(a0)    ; window text font
  696.     lea    pRect(PC),a1
  697.     move.l    portRect(a0),(a1)
  698.     move.l    portRect+4(a0),4(a1)
  699.     clr.l    -(SP)
  700.     _NewRgn
  701.     lea    aRegn(PC),a0
  702.     move.l    (SP)+,(a0)    ; fill in region handle
  703.     clr.w    -(SP)
  704.     _TextMode    ; source copy text mode
  705.     _Initmenus
  706.     _InitCursor
  707.     move.w    #$9f,d0    ; check for trap availability
  708.     _getTrapAddress+$600
  709.     move.l    a0,d3    ; d3 = unimplemented trap addr
  710.     moveq  #$60,d0    ; check for WaitNextEvent
  711.     _getTrapAddress+$600
  712.     cmp.l    a0,d3    ; if <> waitnextevent is avail
  713.     sne    d0
  714.     move.b    d0,wneavail9+3-origin(a3)
  715.     move.l    #$198,d0    ; hwpriv trap addr
  716.     _getTrapAddress+$200
  717.     cmp.l    a0,d3    ; if <> hwpriv is avail
  718.     sne    d0
  719.     move.b    d0,hwpavail9+3-origin(a3)
  720.     move.l  #$1ad,d0    ; gestalt avail
  721.     _getTrapAddress+$200
  722.     cmp.l    a0,d3
  723.     sne    d0
  724.     move.b    d0,hasGestalt9+3-origin(a3)
  725.     move.l    heapend,d0
  726.     sub.l    a3,d0
  727.     move.l    d0,heapTop9-origin(a3)
  728.     move.l    applzone,d0
  729.     sub.l    a3,d0
  730.     move.l    d0,heapBot9-origin(a3)    
  731.     gonext
  732. *
  733.     dcode    HOME,x,intool,home
  734. dohome    move.l    #$f0008,d0
  735.     pushd0
  736.     _MoveTo        ; home
  737.     gonext
  738. *
  739.     dcode    CLS,x,home,cls
  740.     pea    pRect(PC)
  741.     _EraseRect
  742.     jmp    dohome(PC)
  743.     gonext
  744. *
  745.     dcode    SCROLL,x,cls,scroll    ; (dh dv --- )
  746.     popd0
  747.     popd1
  748.     pea    pRect(PC)
  749.     move.w    d1,-(SP)
  750.     move.w    d0,-(SP)
  751.     lea    aregn(PC),a0    ; get dummy region handle
  752.     move.l    (a0),-(SP)
  753.     _ScrollRect
  754.     gonext
  755. *
  756.     dcode    >ORIGIN,x,scroll,setorg
  757.     popd0
  758.     addq.l    #2,SP
  759.     move.w    d0,-(SP)
  760.     _SetOrigin
  761.     gonext
  762. *
  763.     dcode    LINE,x,setorg,xline    ; (dh dv ---)
  764.     popd0
  765.     addq.l    #2,SP
  766.     move.w    d0,-(SP)
  767.     _Line
  768.     gonext
  769. *
  770.     dcode    LINETO,x,xline,xline2    ; (x y --)
  771.     popd0
  772.     addq.l    #2,SP
  773.     move.w    d0,-(sp)
  774.     _LineTo
  775.     gonext
  776. *
  777.     dcode    LIT,x,xline2,lit ; build code header
  778.     move.l    (a4)+,-(SP)    ; push value at IP to stack
  779.     gonext
  780. *
  781.     dcode    WLIT,x,lit,wlit    ; build code header
  782.     move.w    (a4)+,-(SP)    ; push value at IP to stack
  783.     clr.w    -(SP)    ; extend to 32 bits
  784.     gonext
  785. *
  786.     dcode    WLITW,x,wlit,wlitw    ; build code header
  787.     move.w    (a4)+,-(sp)    ; push value at IP to stack
  788.     gonext    ; no extend
  789. *    
  790.     dcode    W@(IP),x,wlitw,wfetip
  791.     move.l    (a6),d0    ; get IP from 1 nest back
  792.     move.w    0(a3,d0.l),-(SP)    ; push the word
  793.     clr.w    -(SP)
  794.     add.l    #2,(a6)    ; increment old IP past word
  795.     gonext
  796. *
  797.     dcode    EXECUTE,x,wfetip,exec
  798.     move.l    (SP)+,d6    ; pop address to execute
  799.     move.l    0(a3,d6.l),d7    ; get contents of CFA
  800.     jmp    0(a3,d7.l)    ; execute the code
  801. *
  802.     dcode    TRAP,x,exec,trap_    ; execute passed-in Tool trap
  803.     popD0        ; get trap in d0
  804.     lea    trapword(PC),a0
  805.     move.w    d0,(a0)    ; store trap inline for execution
  806.     tst.b    hwpavail9+3-origin(a3)
  807.     beq.s    trapword    ; don't flush if hwpriv unavail
  808.     moveq    #1,d0    ; flush the cache on 030,040
  809.     _HWPriv
  810.     nop        ; so we don't get burned by prefetch
  811. trapword    DC.W    $A997    ; start with openresfile
  812.     gonext
  813. *
  814.     dcode    (GESTALT),x,trap_,gestalt_
  815.     moveq    #-1,d0
  816.     move.b    hasGestalt9+3-origin(a3),d1
  817.     beq        nogest
  818.     move.l    (sp),d0
  819.     clr.l    d1
  820.     move.l    d1,a0
  821.     _gestalt
  822.     move.l    a0,(sp)
  823.     ext.l    d0
  824.     bmi.s    nogest
  825.     moveq    #0,d0
  826.     bra.s    isgest
  827. nogest    addq    #4,sp
  828. isgest    move.l    d0,-(sp)
  829.     gonext
  830. *
  831.     dcode    GOTOXY,x,gestalt_,gotoxy
  832.     popd0        ; get Y in d0
  833.     addq.l    #2,SP    ; drop high-level word on stack
  834.     move.w    d0,-(SP)
  835.     _MoveTo        ; call Quickdraw to move pen
  836.     gonext
  837. *
  838.     dcode    BEEP,x,gotoxy,beep    ; ( dur -- )
  839.     addq.l    #2,sp
  840.     _sysbeep
  841.     gonext
  842. *
  843.     dcode    @XY,x,beep,fetxy    ; return X,Y pen location
  844.     pea    ftwork(PC)
  845.     _GetPen
  846.     lea    ftwork(PC),a0
  847.     clr.l    d0
  848.     move.w    2(a0),d0
  849.     pushd0        ; push X value
  850.     move.w    (a0),d0
  851.     pushd0        ; push Y value
  852.     gonext
  853. *
  854.     dcode    BRANCH,x,fetxy,bran
  855.     adda.l    (a4),a4    ; add relative offset to IP
  856.     gonext
  857. *
  858.     dcode    0BRANCH,x,bran,bran0
  859.     move.l    (SP)+,d0    ; pop data stack into d0
  860.     bne    br1    ; if non-0, ignore branch following
  861.     adda.l    (a4),a4    ; else take the branch
  862.     bra.s    br2
  863. br1    addq.l    #4,a4    ; next 32-bit cfa
  864. br2    gonext
  865. *
  866.     dcode    OFBR,x,bran0,ofbr    ; 0branch used by OF clauses
  867.     move.l    (SP)+,d0    ; pop data stack into d0
  868.     bne    ofbr1    ; if non-0, ignore branch
  869.     move.l    (a6),d1    ; get IP from return stack
  870.     move.l    0(a3,d1.l),d2
  871.     add.l    d2,(a6)    ; add to stacked IP
  872.     bra.s    ofbr2
  873. ofbr1    addq.l    #4,(a6)    ; next 32-bit cfa 1 nest back
  874.     addq.l    #4,SP    ; drop the value
  875. ofbr2    gonext
  876. *
  877.     dcode    FAKE,x,ofbr,fake_    ; use as a breakpoint with debugg
  878.     jmp    *(PC)
  879.     gonext
  880. *
  881.     dcode    (LOOP),x,fake_,loop_    ; (loop)
  882.     addq.l    #1,(a6)    ; bump index (long)
  883.     move.l    (a6),d0
  884.     cmp.l    4(a6),d0    ; compare index to limit
  885.     bge    xloop1
  886.     adda.l    (a4),a4    ; branch back to top of loop
  887.     gonext
  888. xloop1    addq.l    #8,a6    ; pop index,limit from return stack
  889.     addq.l    #4,a4
  890.     gonext
  891. *
  892.     dcode    (DO),x,loop_,do_    ; this DO terminates on limit=count
  893.     move.l    (SP),d0
  894.     cmp.l    4(SP),d0    ; does limit=count? if so, terminate
  895.     bne    doloop
  896.     adda.l    (a4),a4    ; forward jump IP
  897.     addq.l    #8,SP
  898.     gonext
  899. doloop    move.l    4(SP),-(a6)    ; limit val to Return stack
  900.     move.l    d0,-(a6)    ; start val
  901.     addq.l    #4,a4    ; skip the jump addr
  902.     addq.l    #8,SP
  903.     gonext
  904. *
  905.     dcode    (LOOP+),x,do_,ploop_
  906.     move.l    (SP)+,d0
  907.     bmi    xploop1
  908.     add.l    d0,(a6)
  909.     move.l    (a6),d0
  910.     cmp.l    4(a6),d0
  911.     bge    xploop2
  912.     adda.l    (a4),a4
  913.     bra.s    xploop3
  914. xploop1    add.l    D0,(a6)
  915.     move.l    (a6),d0
  916.     cmp.l    4(a6),d0
  917.     ble    xploop2
  918.     adda.l    (a4),a4
  919.     bra.s    xploop3
  920. xploop2    addq.l    #8,a6
  921.     addq.l    #4,a4
  922. xploop3    gonext
  923. *
  924.     dcode    I,x,ploop_,i
  925.     move.l    (a6),-(SP)
  926.     gonext
  927. *
  928.     dcode    I+,x,i,iplus    ; add I to top of stack
  929.     move.l    (a6),d0
  930.     add.l    d0,(SP)
  931.     gonext
  932. *
  933.     dcode    I-,x,iplus,iminus
  934.     move.l    (a6),d0
  935.     sub.l    d0,(SP)
  936.     gonext
  937. *
  938.     dcode    I@,x,iminus,ifetch    ; fetch from I as addr
  939.     move.l    (A6),d7
  940.     move.l    0(a3,d7.l),-(sp)
  941.     gonext
  942. *
  943.     dcode    I!,x,ifetch,istore
  944.     move.l    (A6),d7
  945.     move.l    (SP)+,0(a3,d7.l)
  946.     gonext
  947. *
  948.     dcode    IC@,x,istore,icfet
  949.     clr.l    d0
  950.     move.l    (a6),d7
  951.     move.b    0(a3,d7.l),d0
  952.     move.l    d0,-(SP)
  953.     gonext
  954. *
  955.     dcode    IC!,x,icfet,icstor
  956.     move.l    (A6),d7
  957.     move.l    (sp)+,d0
  958.     move.b    d0,0(a3,d7.l)
  959.     gonext
  960. *
  961.     dcode    J,x,icstor,j
  962.     move.l    8(a6),-(SP)
  963.     gonext
  964. *
  965.     dcode    DIGIT,x,j,digit
  966.     popd0
  967.     popd1
  968.     clr.l    d2
  969.     subi.l    #$30,d1
  970.     bmi    dig2
  971.     cmpi.l    #$0a,d1
  972.     bmi    dig1
  973.     subq.l    #7,d1
  974.     cmpi.l    #$0a,d1    ; to fix FIG bug that lets 58-64 pass
  975.     bmi    dig2
  976. dig1    cmp.l    d0,d1
  977.     bge    dig2
  978.     moveq    #1,d2
  979.     pushd1
  980. dig2    pushd2
  981.     gonext
  982. *
  983.     dcode    TRAVERSE,x,digit,traver
  984.     popd0
  985.     popd1
  986.     moveq    #$20,d2
  987.     lea    0(a3,d1.l),a0
  988.     tst.l    d0
  989.     bmi    trav1
  990.     move.b    (a0),d0
  991.     andi.l    #$1f,d0
  992.     adda.l    d0,a0
  993.     move.l    a0,d0
  994.     andi.l    #1,d0
  995.     suba.l    d0,a0
  996.     addq.l    #1,a0
  997.     bra.s    trav2
  998. trav1    tst.b    (a0)
  999.     bmi    trav2
  1000.     subq.l    #1,d2    ; exit early if drags on
  1001.     beq    trav2
  1002.     subq.l    #1,a0
  1003.     bra.s    trav1
  1004. trav2    suba.l    a3,a0
  1005.     move.l    a0,-(SP)
  1006.     gonext
  1007. *
  1008.     dcode    (FIND),x,traver,find_
  1009.     clr.l    d1
  1010.     move.l    (SP)+,d7
  1011.     lea    0(a3,d7.l),a0
  1012. pfind1    movea.l    a0,a2
  1013.     move.l    (SP),d7
  1014.     lea    0(a3,d7.l),a1
  1015.     move.b    (a2)+,d1
  1016.     andi.l    #$03f,d1
  1017.     cmp.b    (a1)+,d1
  1018.     bne    pfind3
  1019.     move.l    d1,d0
  1020. pfind2    cmpm.b    (a1)+,(a2)+
  1021.     bne    pfind3
  1022.     subq.l    #1,d0
  1023.     bne.s    pfind2
  1024.     bsr    odd
  1025.     addq.l    #8,a2
  1026.     suba.l    a3,a2
  1027.     move.l    a2,(SP)
  1028.     move.b    (a0),d0
  1029.     pushD0
  1030.     moveq    #1,d0
  1031.     bra.s    pfind4
  1032. pfind3    movea.l    a0,a2
  1033.     andi.w    #$1f,d1
  1034.     adda.l    d1,a2
  1035.     addq.l    #1,a2
  1036.     bsr    odd
  1037.     move.l    (a2),d7
  1038.     lea    0(a3,d7.l),a0
  1039.     tst.l    (a2)
  1040.     bne.s    pfind1
  1041.     addq.l    #4,SP
  1042.     clr.l    d0
  1043. pfind4    pushD0
  1044.     gonext
  1045. odd    move.l    a2,d0
  1046.     moveq    #1,d1
  1047.     and.l    d1,d0
  1048.     adda.l    d0,a2
  1049.     rts
  1050. *
  1051. ; ( SelPfa ^class -- f OR 1cfa t)
  1052.     dcode    ((FINDM)),x,find_,findm_
  1053.     move.l    (SP)+,d7    ; get relative ^class
  1054.     move.l    (SP)+,d0    ; get SelPfa to match
  1055.     move.l    0(a3,d7.l),d7    ; get contents of ^methods link field
  1056. findm0    lea    0(a3,d7.l),a1    ; get absolute ^methods dict nfa
  1057. findm1    cmp.w    (a1),d0    ; is this the method we want?
  1058.     beq    foundm    ; yes, we found the method
  1059.     move.l    2(a1),d7    ; link to previous method entry
  1060.     beq    notfndm    ; end of methods dict - not found
  1061.     bra.s    findm0
  1062. foundm    addi.l    #10,d7    ; point to 1cfa of method
  1063.     move.l    d7,-(SP)    ; push 1cfa to stack
  1064.     move.l    #1,-(SP)    ; true
  1065.     bra.s    fmexit    ; return to Forth
  1066. notFndm    clr.l    -(SP)
  1067. fmexit    gonext
  1068. *
  1069. *    ( addr delim -- addr n1 n2 n3 )
  1070.     dcode    ENCLOSE,x,findm_,enclos
  1071.     popd0        ; get delim in d0
  1072.     move.l    (SP),d7    ; addr in d7
  1073.     lea    0(a3,d7.l),a0    ; a0 has abs addr
  1074.     clr.l    d1
  1075. encGet    move.b    (a0)+,d2    ; get next byte in d2
  1076.     beq    encNull    ; null - unconditional exit
  1077.     cmpi.b    #9,d2    ; is char a Tab?
  1078.     bne    notab1
  1079.     move.b    #32,d2    ; map tabs to spaces
  1080. notab1    cmp.b    d0,d2    ; does first char = delim?
  1081.     bne    encNext    ; no
  1082.     addq.l    #1,d1    ; get another char
  1083.     bra.s    encGet
  1084. encNull    pushd1        ; found null- push idx at null
  1085.     addq.l    #1,d1    ; push idx of byte following
  1086.     pushd1
  1087.     bra.s    encl5    ; exit
  1088. encNext    pushd1        ; idx of first non-delim
  1089.     subq.l    #1,a0
  1090. encl3    move.b    (a0)+,d2
  1091.     beq    encl4
  1092.     cmp.b    #9,d2    ; is char a Tab?
  1093.     bne    notab2
  1094.     move.b    #32,d2    ; map tabs to spaces
  1095. notab2    cmp.b    d0,d2
  1096.     beq    encl4
  1097.     addq.l    #1,d1
  1098.     bra.s    encl3
  1099. encl4    move.l    d1,-(SP)
  1100.     tst.b    d2
  1101.     beq    encl5
  1102.     addq.l    #1,d1
  1103. encl5    pushd1        ; push unexamined idx and leave
  1104.     gonext
  1105. *
  1106.     dcode    (S=),x,enclos,sequ_    ; ( addr addr len -- b)
  1107.     popd0        ; get length of string comparison
  1108.     subq.l    #1,d0    ; setup counter for dbeq
  1109.     movea.l    (SP)+,a0
  1110.     movea.l    (SP)+,a1
  1111.     adda.l    a3,a0
  1112.     adda.l    a3,a1
  1113. dosequ    cmpm.b    (a0)+,(a1)+
  1114.     dbne    d0,dosequ
  1115.     cmp.w    #-1,d0
  1116.     beq    xsequ    ; counter was exhausted, so true
  1117.     clr.l    -(SP)    ; push false
  1118.     bra.s    nextsequ
  1119. xsequ    move.l    #1,-(SP)    ; push true
  1120. nextsequ    gonext
  1121. *
  1122.     dcode    CMOVE,x,sequ_,cmove
  1123. docmove    move.l    (SP)+,d0
  1124.     movea.l    (SP)+,a1
  1125.     movea.l    (SP)+,a0
  1126.     adda.l    a3,a0
  1127.     adda.l    a3,a1
  1128. cmov1    _BlockMove
  1129.     gonext
  1130. *
  1131. ; the somewhat dreaded multiply routines
  1132. mpy    move.l    (SP)+,-(a6)    ; save return address from jsr
  1133.     tst.w    (SP)    ; try short multiply first
  1134.     bne    mpy1
  1135.     tst.w    4(SP)    ; if both high words=0, we
  1136.     bne    mpy1    ; can do a short multiply
  1137.     popd0
  1138.     popd1
  1139.     mulu    d0,d1
  1140.     pushd1
  1141.     clr.l    d1
  1142.     pushd1
  1143.     move.l    (a6)+,-(SP)
  1144.     rts
  1145. mpy1    popd0        ; this is long multiply
  1146.     popd1
  1147.     moveq    #0,d2
  1148.     move.l    d2,-(SP)
  1149.     move.l    d2,-(SP)
  1150.     move.w    d1,d2
  1151.     mulu    d0,d2
  1152.     move.l    d2,4(SP)
  1153.     move.l    d1,d2
  1154.     swap    d2
  1155.     mulu    d0,d2
  1156.     add.l    d2,2(SP)
  1157.     swap    d0
  1158.     move.w    d1,d2
  1159.     mulu    d0,d2
  1160.     add.l    d2,2(SP)
  1161.     bcc    mpy2
  1162.     addq.w    #1,(SP)
  1163. mpy2    move.l    d1,d2
  1164.     swap    d2
  1165.     mulu    d0,d2
  1166.     add.l    d2,(SP)
  1167.     move.l    (a6)+,-(SP)
  1168.     rts
  1169. smpy    move.l    (SP)+,-(a6)
  1170.     tst.l    (SP)    ; signed multiply
  1171.     smi    d4
  1172.     bpl    smpy1
  1173.     neg.l    (SP)
  1174. smpy1    tst.l    4(SP)
  1175.     smi    d3
  1176.     bpl    smpy2
  1177.     neg.l    4(SP)
  1178. smpy2    eor.b    d3,d4
  1179.     bsr.s    mpy
  1180.     tst.b    d4
  1181.     beq    smpy3
  1182.     neg.l    4(SP)
  1183.     negx.l    (SP)
  1184. smpy3    move.l    (a6)+,-(SP)
  1185.     rts
  1186. xdiv    move.l    (SP)+,-(a6)
  1187.     tst.l    (SP)
  1188.     beq    div5
  1189.     tst.w    (SP)
  1190.     bne    longdiv
  1191.     tst.l    4(SP)
  1192.     bne    longdiv
  1193.     move.l    (SP)+,d2
  1194.     popd0
  1195.     popd1
  1196.     divu    d2,d1
  1197.     bvs    long1
  1198.     clr.l    d2
  1199.     move.w    d1,d2
  1200.     clr.w    d1
  1201.     swap    d1
  1202.     pushd1
  1203.     move.l    d2,-(SP)
  1204.     move.l    (a6)+,-(SP)
  1205.     rts
  1206. longdiv    move.l    (SP)+,d2    ; the dreaded long division
  1207.     popd0
  1208.     popd1
  1209. long1    moveq    #32,d3
  1210.     sub.l    d2,d0
  1211. div1    bmi    div2
  1212.     ori.l    #1,d1
  1213.     subq.w    #1,d3
  1214.     bmi    div3
  1215.     asl.l    #1,d1
  1216.     roxl.l    #1,d0
  1217.     sub.l    d2,d0
  1218.     bra.s    div1
  1219.     
  1220. div2    subq.w    #1,d3
  1221.     bmi    div3
  1222.     asl.l    #1,d1
  1223.     roxl.l    #1,d0
  1224.     add.l    d2,d0
  1225.     bra.s    div1
  1226. div3    tst.l    d0
  1227.     bpl    div4
  1228.     add.l    d2,d0
  1229. div4    pushd0
  1230.     pushd1
  1231.     move.l    (a6)+,-(SP)
  1232.     rts
  1233. div5    addq.l    #4,SP
  1234.     move.l    d2,4(SP)
  1235.     move.l    #$7fffffff,(SP)
  1236.     move.l    (a6)+,-(SP)
  1237.     rts
  1238. sdiv    move.l    (SP)+,-(a6)    ; save return address from jsr
  1239.     tst.l    (SP)    ; signed divide
  1240.     smi    d7    ; d4 change to d7  8-24-91
  1241.     bpl    sdiv1
  1242.     neg.l    (SP)
  1243. sdiv1    tst.l    4(SP)
  1244.     smi    d4    ; d7 changed to d4 to let rem sign = quotient sign
  1245.     bpl    sdiv2
  1246.     neg.l    8(SP)
  1247.     negx.l    4(SP)
  1248. sdiv2    eor.b    d4,d7
  1249.     bsr    xdiv
  1250.     tst.b    d7
  1251.     beq    sdiv3
  1252.     neg.l    (SP)
  1253. sdiv3    tst.b    d4
  1254.     beq    sdiv4
  1255.     neg.l    4(SP)
  1256. sdiv4    move.l    (a6)+,-(SP)
  1257.     rts
  1258. slmod    move.l    (SP)+,-(a6)
  1259.     moveq    #0,d1
  1260.     popd0
  1261.     tst.l    (SP)
  1262.     bpl    slmod1
  1263.     subq.l    #1,d1
  1264. slmod1    pushd1
  1265.     pushd0
  1266.     move.l    (a6)+,-(SP)
  1267.     bra.s    sdiv
  1268. *
  1269.     dcode    U*,x,cmove,ustar
  1270.     bsr    mpy
  1271.     gonext
  1272. *
  1273.     dcode    U/,x,ustar,uslash
  1274.     bsr    xdiv
  1275.     gonext
  1276. *
  1277.     dcode    M*,x,uslash,mstar
  1278.     bsr    smpy
  1279.     gonext
  1280. *
  1281.     dcode    M/,x,mstar,mslash
  1282.     bsr    sdiv
  1283.     gonext
  1284. *
  1285.     dcode    */,x,mslash,starsla
  1286.     move.l    (SP)+,-(a6)
  1287.     bsr    smpy
  1288.     move.l    (a6)+,-(SP)
  1289.     bsr    sdiv
  1290.     move.l    (SP)+,(SP)
  1291.     gonext
  1292. *
  1293.     dcode    */MOD,x,starsla,ssmod
  1294.     move.l    (SP)+,-(a6)
  1295.     bsr    smpy
  1296.     move.l    (a6)+,-(SP)
  1297.     bsr    sdiv
  1298.     gonext
  1299. *
  1300.     dcode    M/MOD,x,ssmod,msmod
  1301.     move.l    (SP)+,-(a6)
  1302.     moveq    #0,d0
  1303.     pushd0
  1304.     move.l    (a6),-(SP)
  1305.     bsr    xdiv
  1306.     move.l    (a6)+,d0
  1307.     move.l    (SP)+,-(a6)
  1308.     pushd0
  1309.     bsr    xdiv
  1310.     move.l    (a6)+,-(SP)
  1311.     gonext
  1312. *
  1313.     dcode    *,x,msmod,star    ; *
  1314.     bsr    smpy
  1315.     addq.l    #4,SP    ; drop top of stack
  1316.     gonext
  1317. *
  1318.     dcode    /,x,star,slash    ; /
  1319.     bsr    slmod
  1320.     move.l    (SP)+,(SP)
  1321.     gonext
  1322. *
  1323.     dcode    /MOD,x,slash,xslmod    ; /MOD
  1324.     bsr    slmod
  1325.     gonext
  1326. *
  1327.     dcode    MOD,x,xslmod,mod    ; MOD
  1328.     bsr    slmod
  1329.     addq.l    #4,SP
  1330.     gonext
  1331. *
  1332.     dcode    D>,x,mod,dgrt    ; D>
  1333.     moveq    #1,d0
  1334.     move.l    8(SP),d1
  1335.     cmp.l    (SP),d1
  1336.     bgt    dgrt1
  1337.     move.l    12(SP),d1
  1338.     cmp.l    4(SP),d1
  1339.     bgt    dgrt1
  1340.     moveq    #0,d0
  1341. dgrt1    adda.l    #16,SP
  1342.     pushd0
  1343.     gonext
  1344. *
  1345.     dcode    D<,x,dgrt,dless    ; D<
  1346.     moveq    #1,d0
  1347.     move.l    8(SP),d1
  1348.     cmp.l    (SP),d1
  1349.     blt    dless1
  1350.     move.l    12(SP),d1
  1351.     cmp.l    4(SP),d1
  1352.     blt    dless1
  1353.     moveq    #0,d0
  1354. dless1    adda.l    #16,SP
  1355.     pushd0
  1356.     gonext
  1357. *
  1358.     dcode    D=,x,dless,dequ    ; D=
  1359.     move.l    (SP),d1
  1360.     cmp.l    8(SP),d1
  1361.     seq    d0
  1362.     move.l    4(SP),d1
  1363.     cmp.l    12(SP),d1
  1364.     seq    d1
  1365.     adda.l    #16,SP
  1366.     and.l    d1,d0
  1367.     bra    setbyt
  1368.     gonext
  1369. *
  1370.     dcode    U<,x,dequ,uless
  1371.     cmp2
  1372.     scs    d0
  1373.     bra.s    setbyt
  1374. *
  1375.     dcode    U>,x,uless,ugrt
  1376.     cmp2
  1377.     scc    d0
  1378.     bra.s    setbyt
  1379. *
  1380.     dcode    <,x,ugrt,less    ; <
  1381.     cmp2
  1382.     slt    d0
  1383.     bra.s    setbyt
  1384. *
  1385.     dcode    >,x,less,grt    ; >
  1386.     cmp2
  1387.     sgt    d0
  1388.     bra.s    setbyt
  1389. *
  1390.     dcode    =,x,grt,equals    ; =
  1391.     cmp2
  1392.     seq    d0
  1393.     bra.s    setbyt
  1394. *
  1395.     dcode    <>,x,equals,nequals
  1396.     cmp2
  1397.     sne    d0
  1398.     bra.s    setbyt
  1399. *
  1400.     dcode    0=,x,nequals,zequ
  1401.     tst.l    (SP)+
  1402.     seq    d0
  1403.     bra.s    setbyt
  1404. *
  1405.     dcode    0<,x,zequ,zless
  1406.     tst.l    (SP)+
  1407.     smi    d0
  1408. setbyt    moveq    #1,d1
  1409.     and.l    d1,d0
  1410.     pushD0
  1411.     gonext
  1412. *
  1413.     dcode    0>,x,zless,zgrt
  1414.     tst.l    (SP)+
  1415.     sgt    d0
  1416.     bra.s    setbyt
  1417. *
  1418.     dcode    <=,x,zgrt,lesequ
  1419.     cmp2
  1420.     sle    d0
  1421.     bra.s    setbyt
  1422. *
  1423.     dcode    >=,x,lesequ,grtequ
  1424.     cmp2
  1425.     sge    d0
  1426.     bra.s    setbyt
  1427. *
  1428.     dcode    0!,x,grtequ,zstore    ; store 0 at addr
  1429.     move.l    (sp)+,d7
  1430.     clr.l    0(a3,d7.l)
  1431.     gonext
  1432. *
  1433.     dcode    0,x,zstore,pzer    ; short, fast 0 word
  1434.     clr.l    -(SP)
  1435.     gonext
  1436. *
  1437.     dcode    1,x,pzer,pone    ; short, fast 1 word
  1438.     move.l    #1,-(SP)
  1439.     gonext
  1440. *
  1441.     dcode    -1,x,pone,pmone    ; short, fast -1 word
  1442.     move.l    #-1,-(SP)
  1443.     gonext
  1444. *
  1445.     dcode    2,x,pmone,ptwo    ; short, fast 2 word
  1446.     move.l    #2,-(SP)
  1447.     gonext
  1448. *
  1449.     dcode    4,x,ptwo,pfour
  1450.     move.l    #4,-(SP)
  1451.     gonext
  1452. *
  1453.     dcode    AND,x,pfour,and_
  1454.     popD0
  1455.     and.l    d0,(SP)
  1456.     gonext
  1457. *
  1458.     dcode    LAND,x,and_,land_
  1459.     popd0
  1460.     tst.l    (SP)
  1461.     beq    land2
  1462.     move.l    #1,(SP)
  1463.     tst.l    d0
  1464.     beq    land1
  1465.     moveq    #1,d0
  1466. land1    and.l    d0,(SP)
  1467. land2    gonext
  1468. *
  1469.     dcode    OR,x,land_,or_
  1470.     popD0
  1471.     or.l    d0,(SP)
  1472.     gonext
  1473. *
  1474.     dcode    LOR,x,or_,lor_
  1475.     popd0
  1476.     tst.l    d0
  1477.     beq    lor1
  1478.     moveq    #1,d0
  1479. lor1    tst.l    (SP)
  1480.     beq    lor2
  1481.     move.l    #1,(SP)
  1482. lor2    or.l    d0,(SP)
  1483.     gonext
  1484. *
  1485.     dcode    XOR,x,lor_,xor
  1486.     popD0
  1487.     eor.l    d0,(SP)
  1488.     gonext
  1489. *
  1490.     dcode    LXOR,x,xor,lxor
  1491.     popd0
  1492.     tst.l    d0
  1493.     beq    lxor1
  1494.     moveq    #1,d0
  1495. lxor1    tst.l    (SP)
  1496.     beq    lxor2
  1497.     move.l    #1,(SP)
  1498. lxor2    eor.l    d0,(SP)
  1499.     gonext
  1500. *
  1501.     dcode    HERE,x,lxor,here
  1502.     move.l    #(dp9-origin),d7
  1503.     move.l    0(a3,d7.l),-(SP)
  1504.     gonext
  1505. *
  1506.     dcode    ALLOT,x,here,allot
  1507.     move.l    #(dp9-origin),d7
  1508.     popD0
  1509.     add.l    d0,0(a3,d7.l)    ; increment DP
  1510.     gonext
  1511. *
  1512.     dcode    SP@,x,allot,spfet
  1513.     move.l    SP,d0
  1514.     sub.l    a3,d0
  1515.     pushD0
  1516.     gonext
  1517. *
  1518.     dcode    SP!,x,spfet,spstor
  1519.     move.l    #(s09-origin),d7
  1520.     move.l    0(a3,d7.l),d7
  1521.     lea    0(a3,d7.l),SP    ; add a3 to it and store in SP
  1522.     gonext
  1523. *
  1524.     dcode    RP@,x,spstor,rpfet
  1525.     move.l    a6,d0
  1526.     sub.l    a3,d0
  1527.     pushD0
  1528.     gonext
  1529. *
  1530.     dcode    RP!,x,rpfet,rpstor
  1531.     move.l    #(r09-origin),d7
  1532.     move.l    0(a3,d7.l),d7
  1533.     lea    0(a3,d7.l),a6    ; add a3 to it and store in RP
  1534.     gonext
  1535. *
  1536.     dcode    MP!,x,rpstor,mpstor
  1537.     move.l    initmp(PC),d5
  1538.     add.l    a3,d5    ; get initmp and add a3 to it
  1539.     gonext
  1540. *
  1541.     dcode    MP@,x,mpstor,mpfet
  1542.     move.l    d5,d0
  1543.     sub.l    a3,d0
  1544.     pushD0
  1545.     gonext
  1546. *
  1547.     dcode    THEPORT,x,mpfet,port_
  1548.     move.l    (a5),a0    ; Point to QD globals
  1549.     move.l    (a0),d0    ; point to current grafport
  1550.     sub.l    a3,d0
  1551.     pushd0
  1552.     gonext
  1553. *
  1554.     dcode    (LCWORD),x,port_,lcword    ; doesn't map to upper ca
  1555.     popd0        ; d0=len to next word
  1556.     lea    in9(PC),a0
  1557.     add.l    d0,(a0)    ; bump IN
  1558.     popd0        ; d0=offs to end of parsed word
  1559.     popd1        ; d1=offs to beg of parsed word
  1560.     sub.w    d1,d0    ; d0=len this word
  1561.     lea    dp9(PC),a0
  1562.     movea.l    (a0),a0    ; a0=relative DP
  1563.     adda.l    a3,a0    ; a0=abs DP = HERE
  1564.     move.b    d0,(a0)    ; store len
  1565.     move.b    #32,1(a0,d0.l)    ; blank at end of word
  1566.     movea.l    (SP)+,a1    ; addr of string
  1567.     adda.l    a3,a1
  1568.     adda.l    d1,a1    ; a1=source address to move from
  1569. wMov    move.b    -1(a1,d0.w),0(a0,d0.w)    ; copy the string
  1570.     subq.l    #1,d0
  1571.     bne.s    wMov
  1572.     gonext
  1573. *
  1574.     dcode    (WORD),x,lcword,word_    ; fast code for WORD
  1575.     popd0        ; d0=len to next word
  1576.     lea    in9(PC),a0
  1577.     add.l    d0,(a0)    ; bump IN
  1578.     popd0        ; d0=offs to end of parsed word
  1579.     popd1        ; d1=offs to beg of parsed word
  1580.     sub.w    d1,d0    ; d0=len this word
  1581.     lea    dp9(PC),a0
  1582.     movea.l    (a0),a0    ; a0=relative DP
  1583.     adda.l    a3,a0    ; a0=abs DP = HERE
  1584.     move.b    d0,(a0)    ; store len
  1585.     move.b    #32,1(a0,d0.l)    ; blank at end of word
  1586.     movea.l    (SP)+,a1    ; addr of string
  1587.     adda.l    a3,a1
  1588.     adda.l    d1,a1    ; a1=source address to move from
  1589. wordMov    move.b    -1(a1,d0.w),0(a0,d0.w)    ; copy the string
  1590.     tst.b    ucase9+3-origin(a3)    ; is upper case flag on?
  1591.     beq.s    wordmov1
  1592.     cmpi.b    #96,0(a0,d0.w)
  1593.     ble    wordmov1    ; map to upper case
  1594.     cmpi.b    #123,0(a0,d0.w)
  1595.     bge    wordMov1
  1596.     subi.b    #32,0(a0,d0.w)
  1597. wordmov1    subq.l    #1,d0
  1598.     bne.s    wordMov
  1599.     gonext
  1600. *
  1601.     dcode    (DODO),x,word_,dodo    ; code for mcfa words
  1602. dodo1    move.w    -2(a3,d7.l),d0    ; pickup len to child's pfa
  1603.     add.l    d0,d6    ; advance wp
  1604.     move.l    d6,-(sp)    ; push pfa for do> code
  1605.     suba.l    a3,a4
  1606.     move.l    a4,-(a6)    ; save old IP on RP
  1607.     lea    10(a3,d7.l),a4    ; point IP to threaded code
  1608.     gonext
  1609. *
  1610. ; this code gets compiled before each piece of DO.. code (10 bytes long)
  1611.     dcode    DOJMP,x,dodo,dojmp
  1612.     move.l    #(dodo1-origin),d0
  1613.     jmp    0(a3,d0.l)
  1614. *
  1615. ; this code gets compiled into the front of each class definition
  1616. ; and is pointed to by the cfa of all objects
  1617.     dcode    DOOBJ,x,dojmp,doobj
  1618. obcode    addq.l    #4,d6    ; d6->pfa of object
  1619. dirObj    move.l    d6,-(SP)    ; push obj addr
  1620.     gonext
  1621. *
  1622. ; this is the code pointed to by the cfa of all classes
  1623.     dcode    DOCLASS,x,doobj,dclass
  1624.     addq.l    #4,d6
  1625.     move.l    d6,-(SP)    ; push ^class on stack
  1626.     move.l    #(bldvec-origin),d6    ; d6 has cfa of BLDVEC
  1627.     move.l    0(a3,d6.l),d7    ; d7 has code addr of BLDVEC
  1628.     jmp    0(a3,d7.l)    ; do it
  1629. *
  1630. ; runtime code for a message to a public object
  1631.     dcode    M0CFA,x,dclass,zcfa
  1632.     movea.l    d5,a2
  1633.     clr.l    d0
  1634.     clr.l    d4
  1635.     move.l    (SP)+,d3    ; get obj addr in d3
  1636.     move.b    8(a3,d6.l),d0    ; pickup #args for named stack
  1637.     beq    noArgs
  1638.     addq.l    #2,d6    ; skip extra word for #args in method
  1639.     move.l    d0,d1    ; save #args
  1640.     lsr.b    #4,d0    ; get #temps nybble
  1641.     beq    noLocs    ; no local vars
  1642.     move.l    d0,d4    ; accum total #cells in d4
  1643.     lsl.b    #2,d0    ; compute #bytes = cells*4
  1644.     suba.l    d0,a2    ; allocate temp space
  1645. noLocs    andi.b    #$0f,d1    ; low nybble has #input parms
  1646.     beq    noIns    ; no input parms
  1647.     add.l    d1,d4
  1648. someArgs    move.l    (SP)+,-(a2)    ; pop data stack to methods stack
  1649.     subq.w    #1,d1
  1650.     bne.s    someArgs    ; transfer all args from data stack
  1651. noIns    move.l    d4,d0
  1652. noArgs    move.l    d0,-(a2)    ; push #args to methods stack
  1653.     move.l    d3,-(a2)    ; d3 has base address of local data
  1654.     move.l    a2,d5
  1655.     suba.l    a3,a4    ; Perform colcode
  1656.     move.l    a4,-(a6)
  1657.     addq.l    #8,d6
  1658.     lea    0(a3,d6.l),a4
  1659.     gonext
  1660. *
  1661. ; runtime code for a message to a private ivar
  1662.     dcode    M1CFA,x,zcfa,onecfa
  1663.     move.l    d5,a2
  1664.     clr.l    d0
  1665.     clr.l    d4
  1666.     move.w    (a4)+,d0    ; get offset to ivar
  1667.     bge    notSelf    ; if negative, this is a Self reference
  1668.     clr.l    d0    ; if self, preserve base addr
  1669. notSelf    move.l    (a2),d2    ; get base address
  1670.     add.l    d0,d2    ; add offset to base address
  1671.     clr.w    d0
  1672.     move.b    4(a3,d6.l),d0    ; pickup #args for named stack
  1673.     beq    noArgs1
  1674.     addq.l    #2,d6    ; skip extra word for #args in method
  1675.     move.l    d0,d1    ; save #args
  1676.     lsr.b    #4,d0    ; get #temps nybble
  1677.     beq    nolocs1
  1678.     move.l    D0,D4    ; total #cells
  1679.     lsl.b    #2,d0    ; compute #bytes = cells*4
  1680.     suba.l    d0,a2    ; allocate temp space
  1681. noLocs1    andi.b    #$0f,d1    ; low nybble has #input parms
  1682.     beq    noins1
  1683.     add.l    d1,d4    ; save #input parms
  1684. args1    move.l    (SP)+,-(a2)    ; pop data stack to methods stack
  1685.     subq.w    #1,d1
  1686.     bne.s    args1    ; transfer all args from data stack
  1687. noins1    move.l    d4,d0
  1688. noArgs1    move.l    d0,-(a2)    ; push #args to methods stack
  1689.     move.l    d2,-(a2)    ; push offset+base to mstack
  1690. mNest    move.l    a2,d5
  1691.     suba.l    a3,a4    ; do colcode nest
  1692.     move.l    a4,-(a6)
  1693.     addq.l    #4,d6
  1694.     lea    0(a3,d6.l),a4
  1695.     gonext
  1696. *
  1697.     dcode    (;M),x,onecfa,semim_    ; this is the ;m definition
  1698.     addq.l    #8,d5    ; pop two entries from mstack
  1699.     movea.l    d5,a2
  1700.     move.l    -4(a2),d0    ; look at #args
  1701.     beq    noPop
  1702.     lsl.w    #2,d0    ; setup to add #args*4
  1703.     adda.l    d0,a2    ; pop #args
  1704.     move.l    a2,d5
  1705. noPop    move.l    (a6)+,d7
  1706.     lea    0(a3,d7.l),a4
  1707.     gonext
  1708. *
  1709.     dcode    ;S,x,semim_,semis    ; this is the ;S definition
  1710.     move.l    (a6)+,d7
  1711.     lea    0(a3,d7.l),a4
  1712.     gonext
  1713. *
  1714.     dcode    COLP,x,semis,pcolon    ; named stack colon code
  1715. pcolcode    move.l    d5,a2
  1716.     clr.l    d0
  1717.     clr.l    d4
  1718.     move.b    4(a3,d6.l),d0    ; pickup #args for named stack
  1719.     beq    noArgs3
  1720.     addq.l    #2,d6    ; skip extra word for #args in method
  1721.     move.l    d0,d1    ; save #args
  1722.     lsr.b    #4,d0    ; get #temps nybble
  1723.     beq    noLocs3    ; no local vars
  1724.     move.l    d0,d4    ; accum total #cells in d4
  1725.     lsl.b    #2,d0    ; compute #bytes = cells*4
  1726.     sub.l    d0,a2    ; allocate temp space
  1727. NoLocs3    andi.b    #$0f,D1    ; low nybble has #input parms
  1728.     beq    noIns3    ; no input parms
  1729.     add.l    d1,d4
  1730. Args3    move.l    (SP)+,-(a2)    ; pop data stack to methods stack
  1731.     subq.w    #1,d1
  1732.     bne.s    Args3    ; transfer all args from data stack
  1733. noIns3    move.l    d4,d0
  1734. noArgs3    move.l    d0,-(a2)    ; push #args to methods stack
  1735.     clr.l    -(a2)    ; waste the objaddr cell
  1736.     move.l    a2,d5    ;
  1737.     suba.l    a3,a4    ; Perform colcode
  1738.     move.l    a4,-(a6)
  1739.     addq.l    #4,d6
  1740.     lea    0(a3,d6.l),a4
  1741.     gonext
  1742. *
  1743.     dcode    (SEMIP),x,pcolon,semip    ; named stack denester co
  1744.     addq.l    #8,d5    ; pop two entries from mstack
  1745.     movea.l    d5,a2
  1746.     move.l    -4(a2),d0    ; look at #args
  1747.     beq    noPops1
  1748.     lsl.w    #2,d0    ; setup to add #args*4
  1749.     adda.l    d0,a2    ; pop #args
  1750.     move.l    a2,d5
  1751. nopops1    move.l    (a6)+,d7
  1752.     lea    0(a3,d7.l),a4
  1753.     gonext
  1754. *
  1755.     dcode    LEAVE,x,semip,leave
  1756.     move.l    (a6),4(a6)
  1757.     gonext
  1758. *
  1759.     dcode    >R,x,leave,toR
  1760.     move.l    (SP)+,-(a6)
  1761.     gonext
  1762. *
  1763.     dcode    R>,x,toR,rFrom
  1764.     move.l    (a6)+,-(SP)
  1765.     gonext
  1766. *
  1767.     dcode    R,x,rFrom,r
  1768.     move.l    (a6),-(SP)
  1769.     gonext
  1770. *
  1771.     dcode    PUSHM,x,r,mpush
  1772.     exg    d5,a2
  1773.     move.l    (SP)+,-(a2)
  1774.     exg    d5,a2
  1775.     gonext
  1776. *
  1777.     dcode    POPM,x,mpush,mpop
  1778.     exg    d5,a2
  1779.     move.l    (a2)+,-(SP)
  1780.     exg    d5,a2
  1781.     gonext
  1782. *
  1783.     dcode    COPYM,x,mpop,mcopy
  1784.     move.l    d5,a2
  1785.     move.l    (a2),-(SP)
  1786.     gonext
  1787. *
  1788.     dcode    EXGM,x,mcopy,mexg
  1789.     exg    d5,a2
  1790.     move.l    (SP),d0
  1791.     move.l    (a2),(SP)
  1792.     move.l    d0,(a2)
  1793.     gonext
  1794. *
  1795.     dcode    DUPM,x,mexg,mdup
  1796. dupm    exg    d5,a2
  1797.     move.l    (a2),-(a2)
  1798.     exg    d5,a2
  1799.     gonext
  1800. *
  1801.     dcode    ADDM,x,mdup,madd
  1802.     popd0
  1803. addmd0    exg    d5,a2    ; copied this from nucleus--suspect!
  1804.     add.l    d0,(a2)
  1805.     exg    d5,a2
  1806.     gonext
  1807. *
  1808.     dcode    DROPM,x,madd,mdrop
  1809.     exg    d5,a2    ; *** popmd0
  1810.     move.l    (a2)+,d0
  1811.     exg    d5,a2
  1812.     gonext
  1813. *
  1814.     dcode    MP0,x,mdrop,mp0    ; mstack picks for named parms
  1815.     move.l    d5,a2
  1816.     move.l    8(a2),-(SP)    ; push parm to data stack
  1817.     gonext
  1818. *
  1819.     dcode    MP1,x,mp0,mp1    ; mstack picks for named parms
  1820.     move.l    d5,a2
  1821.     move.l    12(a2),-(SP)    ; push parm to data stack
  1822.     gonext
  1823. *
  1824.     dcode    MP2,x,mp1,mp2    ; mstack picks for named parms
  1825.     move.l    d5,a2
  1826.     move.l    16(a2),-(SP)    ; push parm to data stack
  1827.     gonext
  1828. *
  1829.     dcode    MP3,x,mp2,mp3    ; mstack picks for named parms
  1830.     move.l    d5,a2
  1831.     move.l    20(a2),-(SP)    ; push parm to data stack
  1832.     gonext
  1833. *
  1834.     dcode    MP4,x,mp3,mp4    ; mstack picks for named parms
  1835.     move.l    d5,a2
  1836.     move.l    24(a2),-(SP)    ; push parm to data stack
  1837.     gonext
  1838. *
  1839.     dcode    MP5,x,mp4,mp5    ; mstack picks for named parms
  1840.     move.l    d5,a2
  1841.     move.l    28(a2),-(SP)    ; push parm to data stack
  1842.     gonext
  1843. *
  1844.     dcode    MS0,x,mp5,ms0    ; mstack stores for named parms
  1845.     move.l    d5,a2
  1846.     move.l    (SP)+,8(a2)    ; replace parm val with top of stack
  1847.     gonext
  1848. *
  1849.     dcode    MS1,x,ms0,ms1    ; mstack stores for named parms
  1850.     move.l    d5,a2
  1851.     move.l    (SP)+,12(a2)    ; replace parm val with top of stack
  1852.     gonext
  1853. *
  1854.     dcode    MS2,x,ms1,ms2    ; mstack stores for named parms
  1855.     move.l    d5,a2
  1856.     move.l    (SP)+,16(a2)    ; replace parm val with top of stack
  1857.     gonext
  1858. *
  1859.     dcode    MS3,x,ms2,ms3    ; mstack stores for named parms
  1860.     move.l    d5,a2
  1861.     move.l    (SP)+,20(a2)    ; replace parm val with top of stack
  1862.     gonext
  1863. *
  1864.     dcode    MS4,x,ms3,ms4    ; mstack stores for named parms
  1865.     move.l    d5,a2
  1866.     move.l    (SP)+,24(a2)    ; replace parm val with top of stack
  1867.     gonext
  1868. *
  1869.     dcode    MS5,x,ms4,ms5    ; mstack stores for named parms
  1870.     move.l    d5,a2
  1871.     move.l    (SP)+,28(a2)    ; replace parm val with top of stack
  1872.     gonext
  1873. *
  1874.     dcode    (++>),x,ms5,minc    ; increment named parm
  1875.     move.l    d5,a2
  1876.     move.w    (a4)+,d0    ; get element offset
  1877.     move.l    (sp)+,d1    ; get increment value
  1878.     add.l    d1,0(a2,d0.w)    ; increment the cell
  1879.     gonext
  1880. *
  1881.     dcode    (EX>),x,minc,mdo    ; execute a procedural arg
  1882.     move.l    d5,a2
  1883.     move.w    (a4)+,d0    ; get offset to named parm
  1884.     move.l    0(a2,d0.w),d6    ; get the cfa
  1885.     move.l    0(a3,d6.l),d7    ; get the code
  1886.     jmp    0(a3,d7.l)
  1887. *
  1888.     dcode    +,x,mdo,plus
  1889.     popD0
  1890.     add.l    d0,(SP)
  1891.     gonext
  1892. *
  1893.     dcode    -,x,plus,subt
  1894.     popD0
  1895.     sub.l    d0,(SP)
  1896.     gonext
  1897. *
  1898.     dcode    MAX,x,subt,max
  1899.     popD0
  1900.     cmp.l    (SP),d0
  1901.     blt    maxq
  1902.     move.l    d0,(SP)
  1903. maxq    gonext
  1904. *
  1905.     dcode    MIN,x,max,min
  1906.     popD0
  1907.     cmp.l    (SP),d0
  1908.     bgt    minq
  1909.     move.l    d0,(SP)
  1910. minq    gonext
  1911. *
  1912.     dcode    NEGATE,x,min,minus
  1913. mins1    neg.l    (SP)
  1914.     gonext
  1915. *
  1916.     dcode    DNEGATE,x,minus,dminus
  1917. dmins1    neg.l    4(SP)
  1918.     negx.l    (SP)
  1919.     gonext
  1920. *
  1921.     dcode    CFA,x,dminus,cfa
  1922.     subq.l    #4,(SP)
  1923.     gonext
  1924. *
  1925.     dcode    +-,x,cfa,plmin
  1926.     tst.l    (SP)+
  1927.     bmi.s    mins1
  1928.     gonext
  1929. *
  1930.     dcode    ABS,x,plmin,abs
  1931.     tst.l    (SP)
  1932.     bmi.s    mins1
  1933.     gonext
  1934. *
  1935.     dcode    DABS,x,abs,dabs
  1936.     tst.l    (SP)
  1937.     bmi.s    dmins1
  1938.     gonext
  1939. *
  1940.     dcode    S->D,x,dabs,sToD
  1941.     moveq    #0,d0
  1942.     tst.l    (SP)
  1943.     bpl    GOHERE
  1944.     subq.l    #1,d0
  1945. GOHERE    pushd0
  1946.     gonext
  1947. *
  1948.     dcode    OVER,x,sToD,over
  1949.     move.l    4(SP),-(SP)
  1950.     gonext
  1951. *
  1952.     dcode    2OVER,x,over,over2
  1953.     move.l    12(SP),-(SP)
  1954.     move.l    12(SP),-(SP)
  1955.     gonext
  1956. *
  1957.     dcode    DROP,x,over2,drop
  1958.     addq.l    #4,SP
  1959.     gonext
  1960. *
  1961.     dcode    2DROP,x,drop,drop2
  1962.     addq.l    #8,SP
  1963.     gonext
  1964. *
  1965.     dcode    SWAP,x,drop2,swap_
  1966.     popD0
  1967.     move.l    (SP),d1
  1968.     move.l    d0,(SP)
  1969.     pushD1
  1970.     gonext
  1971. *
  1972.     dcode    2SWAP,x,swap_,swap2
  1973.     popD0
  1974.     popD1
  1975.     move.l    (SP)+,d3
  1976.     move.l    (SP),d4
  1977.     move.l    d1,(SP)
  1978.     move.l    d0,-(SP)
  1979.     move.l    d4,-(SP)
  1980.     move.l    d3,-(SP)
  1981.     gonext
  1982. *
  1983.     dcode    DUP,x,swap2,dup
  1984.     move.l    (SP),-(SP)
  1985.     gonext
  1986. *
  1987.     dcode    2DUP,x,dup,dup2
  1988.     move.l    4(SP),-(SP)
  1989.     move.l    4(SP),-(SP)
  1990.     gonext
  1991. *
  1992.     dcode    -DUP,x,dup2,mindup
  1993.     tst.l    (SP)
  1994.     beq    ddup
  1995.     move.l    (SP),-(SP)
  1996. ddup    gonext
  1997. *
  1998.     dcode    +!,x,mindup,plstor
  1999.     move.l    (SP)+,d7
  2000.     popD0
  2001.     add.l    d0,0(a3,d7.l)
  2002.     gonext
  2003. *
  2004.     dcode    TOGGLE,x,plstor,toggle
  2005.     popD0
  2006.     move.l    (SP)+,d7
  2007.     eor.b    d0,0(a3,d7.l)
  2008.     gonext
  2009. *
  2010.     dcode    W@,x,toggle,wfetch    ; this is a 16-bit fetch
  2011.     clr.l    d0
  2012.     move.l    (SP),d7
  2013.     move.w    0(a3,d7.l),d0
  2014.     move.l    d0,(SP)
  2015.     gonext
  2016. *
  2017.     dcode    @,x,wfetch,fetch    ; this is a 32-bit fetch
  2018.     move.l    (SP),d7
  2019.     move.l    0(a3,d7.l),(SP)
  2020.     gonext
  2021. *
  2022.     dcode    C@,x,fetch,cfetch
  2023.     clr.l    d0
  2024.     move.l    (SP),d7
  2025.     move.b    0(a3,d7.l),d0
  2026.     move.l    d0,(SP)
  2027.     gonext
  2028. *
  2029.     dcode    MW@,x,cfetch,mwfetch    ; 16-bit fetch from mstack addr
  2030.     move.l    d5,a2
  2031.     clr.l    d0
  2032.     move.l    (a2),d7
  2033.     move.w    0(a3,d7.l),d0
  2034.     ext.l    d0    ; sign-extend
  2035.     move.l    d0,-(SP)
  2036.     gonext
  2037. *
  2038.     dcode    M@,x,mwfetch,mfetch    ; this is a 32-bit fetch
  2039.     move.l    d5,a2
  2040.     move.l    (a2),d7
  2041.     move.l    0(a3,d7.l),-(SP)
  2042.     gonext
  2043. *
  2044.     dcode    2@,x,mfetch,fetch2    ; ( double word fetch )
  2045.     move.l    (SP),d7
  2046.     lea    0(a3,d7.l),a0
  2047.     move.l    (a0)+,-(sp)
  2048.     move.l    (a0),4(SP)
  2049.     gonext
  2050. *
  2051.     dcode    W!,x,fetch2,wstore    ; 16-bit store
  2052.     move.l    (SP)+,d7    ; address is relative to a3
  2053.     popD0        ; d0 has value
  2054.     move.w    d0,0(a3,d7.l)
  2055.     gonext
  2056. *
  2057.     dcode    W+!,x,wstore,wpstore    ; 16-bit plus store
  2058.     move.l    (SP)+,d7
  2059.     popD0
  2060.     add.w    d0,0(a3,d7.l)
  2061.     gonext
  2062. *
  2063.     dcode    !,x,wpstore,store    ; 32-bit store
  2064.     move.l    (SP)+,d7    ; address is relative to a3
  2065.     popD0        ; d0 has value
  2066.     move.l    d0,0(a3,d7.l)
  2067.     gonext
  2068. *
  2069.     dcode    C!,x,store,cstore
  2070.     move.l    (SP)+,d7
  2071.     popD0
  2072.     move.b    d0,0(a3,d7.l)
  2073.     gonext
  2074. *
  2075.     dcode    C+!,x,cstore,cpstore    ; 8 bit plus store
  2076.     move.l    (SP)+,d7
  2077.     popD0
  2078.     add.b    d0,0(a3,d7.l)
  2079.     gonext
  2080. *
  2081.     dcode    MW!,x,cpstore,mwstore    ; 16-bit store to addr on mstack
  2082.     move.l    d5,a2
  2083.     move.l    (a2),d7    ; address is relative to a3
  2084.     popD0        ; d0 has value
  2085.     move.w    d0,0(a3,d7.l)
  2086.     gonext
  2087. *
  2088.     dcode    M!,x,mwstore,mstore    ; 32-bit store to addr on mstack
  2089.     move.l    d5,a2
  2090.     move.l    (a2),d7    ; address is relative to a3
  2091.     popD0        ; d0 has value
  2092.     move.l    d0,0(a3,d7.l)
  2093.     gonext
  2094. *
  2095.     dcode    2!,x,mstore,store2    ; ( double word store )
  2096.     move.l    (SP)+,d7
  2097.     lea    0(a3,d7.l),a0
  2098.     move.l    (SP)+,(a0)+
  2099.     move.l    (SP)+,(a0)
  2100.     gonext
  2101. *
  2102.     dcode    D+,x,store2,dplus    ; 64-bit add
  2103.     popd0
  2104.     popd1
  2105.     move.l    (SP)+,d2
  2106.     move.l    (sp)+,d3
  2107.     add.l    d1,d3
  2108.     addx.l    d0,d2
  2109.     move.l    d3,-(SP)
  2110.     move.l    d2,-(SP)
  2111.     gonext
  2112. *
  2113.     dcode    1+,x,dplus,plus1
  2114.     addq.l    #1,(SP)
  2115.     gonext
  2116. *
  2117.     dcode    2+,x,plus1,plus2
  2118.     addq.l    #2,(SP)
  2119.     gonext
  2120. *
  2121.     dcode    3+,x,plus2,plus3
  2122.     addq.l    #3,(SP)
  2123.     gonext
  2124. *
  2125.     dcode    4+,x,plus3,plus4
  2126.     addq.l    #4,(SP)
  2127.     gonext
  2128. *
  2129.     dcode    8+,x,plus4,plus8
  2130.     addq.l    #8,(SP)
  2131.     gonext
  2132. *
  2133.     dcode    1-,x,plus8,min1
  2134.     subq.l    #1,(SP)
  2135.     gonext
  2136. *
  2137.     dcode    2-,x,min1,min2
  2138.     subq.l    #2,(SP)
  2139.     gonext
  2140. *
  2141.     dcode    4-,x,min2,min4
  2142.     subq.l    #4,(SP)
  2143.     gonext
  2144. *
  2145.     dcode    8-,x,min4,min8
  2146.     subq.l    #8,(SP)
  2147.     gonext
  2148. *
  2149.     dcode    2*,x,min8,times2
  2150.     move.l    (SP),d0
  2151.     asl.l    #1,d0
  2152.     move.l    d0,(SP)
  2153.     gonext
  2154. *
  2155.     dcode    4*,x,times2,times4
  2156.     move.l    (SP),d0
  2157.     asl.l    #2,d0
  2158.     move.l    d0,(SP)
  2159.     gonext
  2160. *
  2161.     dcode    8*,x,times4,times8
  2162.     move.l    (SP),d0
  2163.     asl.l    #3,d0
  2164.     move.l    d0,(SP)
  2165.     gonext
  2166. *
  2167.     dcode    2/,x,times8,xdiv2
  2168.     move.l    (SP),d0
  2169.     asr.l    #1,d0
  2170.     move.l    d0,(SP)
  2171.     gonext
  2172. *
  2173. ; ^elem expects base addr on mstack, and an index on pstack
  2174.     dcode    (^ELEM),x,xdiv2,pelem    ; return address of array eleme
  2175.     move.l    d5,a2    ; pickup base address on mstack
  2176.     move.l    (a2),d7    ; base of object in d7
  2177.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2178.     clr.l    d1
  2179.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2180.     add.l    d1,d7    ; d7 points to idx hdr
  2181.     move.w    0(a3,d7.l),d1    ; fetch width word from header
  2182.     mulu    2(SP),d1    ; multiply index * width
  2183.     add.l    d1,d7    ; add to base address
  2184.     addq.l    #4,d7    ; skip the header
  2185.     move.l    d7,(SP)    ; leave on data stack
  2186.     gonext
  2187. *
  2188.     dcode    IDXBASE,x,pelem,idxbas    ; idx addr of indexed object
  2189.     move.l    d5,a2    ; pickup base address on mstack
  2190.     move.l    (a2),d7    ; base of object in d7
  2191.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2192.     clr.l    d1
  2193.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2194.     add.l    d1,d7    ; d7 points to idx hdr
  2195.     addq.l    #4,d7    ; skip the idx hdr
  2196.     move.l    d7,-(SP)    ; leave the ^ixdata
  2197.     gonext
  2198. *
  2199.     dcode    LIMIT,x,idxbas,limit    ; limit of indexed object
  2200.     move.l    d5,a2    ; pickup base address on mstack
  2201.     move.l    (a2),d7    ; base of object in d7
  2202.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2203.     clr.l    d1
  2204.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2205.     add.l    d1,d7    ; d7 points to idx hdr
  2206.     move.w    2(a3,d7.l),-(SP)    ; leave the limit
  2207.     clr.w    -(SP)
  2208.     gonext
  2209. *
  2210.     dcode    RANGE?,x,limit,qrange    ; index out of range?
  2211.     move.l    d5,a2    ; pickup base address on mstack
  2212.     move.l    (a2),d7    ; base of object in d7
  2213.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2214.     clr.l    d1
  2215.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2216.     add.l    d1,d7    ; d7 points to idx hdr
  2217.     clr.l    d0
  2218.     move.w    2(a3,d7.l),d0    ; get the limit
  2219.     cmp.l    (SP),d0    ; is limit > index?
  2220.     sle    d1    ; true if out of range
  2221.     neg.b    d1    ; forth boolean
  2222.     move.l    d1,-(SP)
  2223.     gonext
  2224. *
  2225.     dcode    AT1,x,qrange,at1    ; at opt for byte elements
  2226.     move.l    d5,a2    ; pickup base address on mstack
  2227.     move.l    (a2),d7    ; base of object in d7
  2228.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2229.     clr.l    d1
  2230.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2231.     add.l    d1,d7    ; d7 points to idx hdr
  2232.     add.l    (SP)+,d7    ; add the index
  2233.     clr.l    d0
  2234.     move.b    4(a3,d7.l),d0    ; fetch addr+4 (for idx hdr)
  2235.     move.l    d0,-(SP)
  2236.     gonext
  2237. *
  2238.     dcode    AT2,x,at1,at2    ; at opt for byte elements
  2239.     move.l    d5,a2    ; pickup base address on mstack
  2240.     move.l    (a2),d7    ; base of object in d7
  2241.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2242.     clr.l    d1
  2243.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2244.     add.l    d1,d7    ; d7 points to idx hdr
  2245.     move.l    (SP),d0    ; get the index
  2246.     lsl.w    #1,d0    ; index * 2
  2247.     add.l    d0,d7    ; add the index
  2248.     move.w    4(a3,d7.l),d1    ; fetch addr+4 (for idx hdr)
  2249.     ext.l    d1    ; sign extend
  2250.     move.l    d1,(sp)
  2251.     gonext
  2252. *
  2253.     dcode    AT4,x,at2,at4    ; at opt for long elements
  2254.     move.l    d5,a2    ; pickup base address on mstack
  2255.     move.l    (a2),d7    ; base of object in d7
  2256.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2257.     clr.l    d1
  2258.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2259.     add.l    d1,d7    ; d7 points to idx hdr
  2260.     move.l    (SP)+,d0    ; get the index
  2261.     lsl.w    #2,d0    ; index * 4
  2262.     add.l    d0,d7    ; add the index
  2263.     move.l    4(a3,d7.l),-(SP)    ; fetch addr+4 (for idx hdr)
  2264.     gonext
  2265. *
  2266.     dcode    TO1,x,at4,to1    ; To opt for byte elements
  2267.     move.l    d5,a2    ; pickup base address on mstack
  2268.     move.l    (a2),d7    ; base of object in d7
  2269.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2270.     clr.l    d1
  2271.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2272.     add.l    d1,d7    ; d7 points to idx hdr
  2273.     add.l    (SP)+,d7    ; add the index
  2274.     move.l    (SP)+,d0
  2275.     move.b    d0,4(a3,d7.l)    ; store to addr+4 (for idx hdr)
  2276.     gonext
  2277. *
  2278.     dcode    TO2,x,to1,to2    ; To opt for byte elements
  2279.     move.l    d5,a2    ; pickup base address on mstack
  2280.     move.l    (a2),d7    ; base of object in d7
  2281.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2282.     clr.l    d1
  2283.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2284.     add.l    d1,d7    ; d7 points to idx hdr
  2285.     move.l    (SP)+,d0    ; get the index
  2286.     lsl.w    #1,d0    ; index * 2
  2287.     add.l    d0,d7    ; add the index
  2288.     move.l    (sp)+,d1
  2289.     move.w    d1,4(a3,d7.l)    ; store to addr+4 (for idx hdr)
  2290.     gonext
  2291. *
  2292.     dcode    TO4,x,to2,to4    ; to opt for long elements
  2293.     move.l    d5,a2    ; pickup base address on mstack
  2294.     move.l    (a2),d7    ; base of object in d7
  2295.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2296.     clr.l    d1
  2297.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2298.     add.l    d1,d7    ; d7 points to idx hdr
  2299.     move.l    (SP)+,d0    ; get the index
  2300.     lsl.w    #2,d0    ; index * 4
  2301.     add.l    d0,d7    ; add the index
  2302.     move.l    (SP)+,4(a3,d7.l)    ; store to addr+4 (for idx hdr)
  2303.     gonext
  2304. *
  2305.     dcode    ++4,x,to4,inc4    ; inc opt for long elements
  2306.     move.l    d5,a2    ; pickup base address on mstack
  2307.     move.l    (a2),d7    ; base of object in d7
  2308.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2309.     clr.l    d1
  2310.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2311.     add.l    d1,d7    ; d7 points to idx hdr
  2312.     move.l    (SP)+,d0    ; get the index
  2313.     lsl.w    #2,d0    ; index * 4
  2314.     add.l    d0,d7    ; add the index
  2315.     move.l    (SP)+,d1    ; get increment
  2316.     add.l    d1,4(a3,d7.l)    ; inc addr+4 (for idx hdr)
  2317.     gonext
  2318. *
  2319.     dcode    ++2,x,inc4,inc2    ; inc opt for word elements
  2320.     move.l    d5,a2    ; pickup base address on mstack
  2321.     move.l    (a2),d7    ; base of object in d7
  2322.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2323.     clr.l    d1
  2324.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2325.     add.l    d1,d7    ; d7 points to idx hdr
  2326.     move.l    (SP)+,d0    ; get the index
  2327.     lsl.w    #1,d0    ; index * 4
  2328.     add.l    d0,d7    ; add the index
  2329.     move.l    (SP)+,d1    ; get increment
  2330.     add.w    d1,4(a3,d7.l)    ; inc addr+4 (for idx hdr)
  2331.     gonext
  2332. *
  2333.     dcode    ++1,x,inc2,inc1    ; inc opt for byte elements
  2334.     move.l    d5,a2    ; pickup base address on mstack
  2335.     move.l    (a2),d7    ; base of object in d7
  2336.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2337.     clr.l    d1
  2338.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2339.     add.l    d1,d7    ; d7 points to idx hdr
  2340.     move.l    (SP)+,d0    ; get the index
  2341.     add.l    d0,d7    ; add the index
  2342.     move.l    (SP)+,d1    ; get increment
  2343.     add.b    d1,4(a3,d7.l)    ; inc addr+4 (for idx hdr)
  2344.     gonext
  2345. *
  2346. ; fast left lshift ( val #shift -- val )
  2347.     dcode    <<,x,inc1,shfl
  2348.     popd0
  2349.     popd1
  2350.     lsl.l    d0,d1
  2351.     move.l    d1,-(SP)
  2352.     gonext
  2353. *
  2354. ; fast right lshift ( val #shift -- val )
  2355.     dcode    >>,x,shfl,shfr
  2356.     popd0
  2357.     popd1
  2358.     lsr.l    d0,d1
  2359.     move.l    d1,-(SP)
  2360.     gonext
  2361. *
  2362.     dcode    (ABS),x,shfr,abs_    ; leave absolute of mstack addr
  2363.     move.l    d5,a2
  2364.     move.l    (a2),d0
  2365.     add.l    a3,d0
  2366.     move.l    d0,-(SP)
  2367.     gonext
  2368. *
  2369.     dcode    COUNT,x,abs_,count
  2370.     move.l    (SP),d0
  2371.     add.l    #1,(SP)
  2372.     clr.l    d1
  2373.     move.b    0(A3,d0.l),d1
  2374.     move.l    d1,-(SP)
  2375.     gonext
  2376. *
  2377.     dcode    DEPTH,x,count,depth
  2378.     move.l    SP,d0
  2379.     sub.l    a3,d0
  2380.     move.l    #(s09-origin),d7
  2381.     sub.l    0(a3,d7.l),d0
  2382.     neg.l    d0
  2383.     asr.l    #2,d0
  2384.     pushD0
  2385.     gonext
  2386. *
  2387.     dcode    FILL,x,depth,fil
  2388.     popD0
  2389. fill1    popD1
  2390.     move.l    (SP)+,d7
  2391.     lea    0(a3,d7.l),a0
  2392. fil1    subq.l    #1,d1
  2393.     bmi    fil2
  2394.     move.b    d0,(a0)+
  2395.     bra.s    fil1
  2396. fil2    gonext
  2397. *
  2398.     dcode    ERASE,x,fil,era
  2399.     clr.l    d0
  2400.     bra.s    fill1
  2401. *
  2402.     dcode    BLANKS,x,era,blanks
  2403.     moveq    #$20,d0
  2404.     bra.s    fill1
  2405. *    
  2406.     dcode    +BASE,x,blanks,basadr
  2407.     move.l    (SP)+,d7
  2408.     pea    0(a3,d7.l)    ; push absolute address = base+pa
  2409.     gonext
  2410. *
  2411.     dcode    -BASE,x,basadr,minbas
  2412.     move.l    a3,d0
  2413.     sub.l    d0,(SP)
  2414.     gonext
  2415. *
  2416.     dcode    ROT,x,minbas,rot
  2417.     popD0
  2418.     popD1
  2419.     move.l    (SP),d2
  2420.     move.l    d1,(SP)
  2421.     pushD0
  2422.     move.l    d2,-(SP)
  2423.     gonext
  2424. *
  2425.     dcode    PICK,x,rot,pick
  2426.     move.l    (SP),d0
  2427.     asl.l    #2,d0    ; index * 4
  2428.     move.L    0(SP,d0.w),(SP)
  2429.     gonext
  2430. *
  2431.     dcode    RESET,x,pick,rset    ; reboot the machine
  2432.     reset
  2433. *
  2434.     dcode    (FDOS),x,rset,fdos    ; general file system trap call
  2435.     lea    fdtrap(PC),a0    ; stack : (pblock trap --- result)
  2436.     clr.l    d1
  2437.     move.w    (SP)+,d1    ; function selector to d0 later
  2438.     move.w    (SP)+,(a0)    ; move in trap#
  2439.     movea.l    (SP)+,a0    ; file control block
  2440.     adda.l    a3,a0    ; make it absolute
  2441.     tst.b    hwpavail9+3-origin(a3)    ; flush cache if necessary
  2442.     beq.s    fdt0
  2443.     moveq    #1,d0
  2444.     _HWPriv
  2445. fdt0    move.l    d1,d0    ; restore d0
  2446. fdtrap    DC.W    0    ; call Toolbox
  2447.     move.w    ioResult(a0),d0    ; leave result on stack
  2448.     ext.l    d0
  2449.     pushd0
  2450.     gonext
  2451. *
  2452.     dcode    (MAKE),x,fdos,make_
  2453.     move.l    (SP)+,a0    ; parm block offset in a0
  2454.     add.l    a3,a0    ; make it absolute
  2455.     _Hcreate        ; call Toolbox
  2456.     move.w    ioResult(a0),d0    ; leave result on stack
  2457.     ext.l    d0
  2458.     pushd0
  2459.     gonext
  2460. *
  2461.     dcode    (OPEN),x,make_,open_
  2462.     popd0        ; get access mode in d0
  2463.     move.l    (SP)+,a0    ; parm block offset in a0
  2464.     add.l    a3,a0    ; make it absolute
  2465.     move.b    d0,ioPermssn(a0)    ; set i/o permission
  2466.     _Hopen        ; open the file
  2467.     move.w    ioResult(a0),d0    ; leave result on stack
  2468.     ext.l    d0
  2469.     pushd0
  2470.     gonext
  2471. *
  2472.     dcode    (CLOSE),x,open_,close_
  2473.     move.l    (SP)+,a0    ; parm block offset in a0
  2474.     add.l    a3,a0    ; make it absolute
  2475.     _close        ; call Toolbox CLOSE
  2476.     move.w    ioResult(a0),d0    ; leave result on stack
  2477.     ext.l    d0
  2478.     pushd0
  2479.     gonext
  2480. *
  2481.     dcode    (DELETE),x,close_,delet_
  2482.     move.l    (SP)+,a0    ; parm block offset in a0
  2483.     add.l    a3,a0    ; make it absolute
  2484.     _delete        ; call Toolbox DELETE
  2485.     move.w    ioResult(a0),d0    ; leave result on stack
  2486.     ext.l    d0
  2487.     pushd0
  2488.     gonext
  2489. *
  2490.     dcode    (READ),x,delet_,read_
  2491.     popD0        ; pop buffer address into d0
  2492.     add.l    a3,d0    ; make it absolute
  2493.     popD1        ; get count in d1
  2494.     move.l    (SP)+,a0    ; parm block offset in a0
  2495.     add.l    a3,a0    ; make it absolute
  2496.     move.l    d0,iobuffer(a0)    ; store buffer pointer in parm block
  2497.     move.l    d1,ioReqCount(a0)    ; store count in parm block
  2498.     _read        ; call Toolbox read
  2499.     move.w    ioResult(a0),d0    ; leave result on stack
  2500.     ext.l    d0
  2501.     pushd0
  2502.     gonext
  2503. *
  2504.     dcode    (WRITE),x,read_,write_
  2505.     popD0        ; pop buffer address into d0
  2506.     add.l    a3,d0    ; make it absolute
  2507.     popD1        ; get count in d1
  2508.     move.l    (SP)+,a0    ; parm block offset in a0
  2509.     add.l    a3,a0    ; make it absolute
  2510.     move.l    d0,iobuffer(a0)    ; store buffer pointer in parm block
  2511.     move.l    d1,ioReqCount(a0)    ; store count in parm block
  2512.     _write        ; call Toolbox read
  2513.     move.w    ioResult(a0),d0    ; leave result on stack
  2514.     ext.l    d0
  2515.     pushD0
  2516.     gonext
  2517. *
  2518.     dcode    (LSEEK),x,write_,lseek
  2519.     popD0        ; pickup position offset in D0
  2520.     popD1        ; pickup positioning mode in D1
  2521.     move.l    (SP)+,a0    ; pop pba
  2522.     add.l    a3,a0
  2523.     move.l    d0,ioPosOffset(a0)    ; set offset in parm block
  2524.     move.w    d1,ioPosMode(a0)    ; set mode in parm block
  2525.     _SetFPos
  2526.     move.w    ioResult(a0),d0    ; leave result on stack
  2527.     ext.l    d0
  2528.     pushd0
  2529.     gonext
  2530. *
  2531. ; ------- (;CODE) is needed by the following words
  2532.     dcol    (;CODE),x,lseek,pscode
  2533.     cfas    rfrom,latest,pfa,cfa,store,semis
  2534. *
  2535. ; ------- The following words are ;CODE type words
  2536.     dcol    CONSTANT,x,pscode,const
  2537.     cfas    kreate,comma
  2538.     scode        ; points to (;CODE)
  2539. concode    addq.l    #4,d6    ; runtime code for constant
  2540.     move.l    0(a3,d6.l),-(SP)
  2541.     gonext
  2542. *
  2543.     dcol    :,I,const,colon    ; this colon doesn't set Context
  2544.     cfas    qexec,stcsp    ; to Current.
  2545.     cfas    kreate,rbrak
  2546.     scode
  2547. colcode    suba.l    a3,a4    ; convert absolute address to offset
  2548.     move.l    a4,-(a6)    ; push current IP to Return stack
  2549.     addq.l    #4,d6    ; advance WP to pfa of word being def.
  2550.     lea    0(a3,d6.l),a4    ; get absolute addr in A4
  2551.     gonext
  2552. *
  2553.     dcol    DOES>,x,colon,does
  2554.     cfas    rfrom,latest,pfa
  2555.     DATA    store-origin
  2556.     scode
  2557. doescode    addq.l    #4,d6
  2558.     suba.l    a3,a4
  2559.     move.l    a4,-(a6)
  2560.     move.l    0(a3,d6.l),d7
  2561.     lea    0(a3,d7.l),a4
  2562.     addq.l    #4,d6
  2563.     move.l    d6,-(SP)
  2564.     gonext
  2565. *
  2566.     dcol    VARIABLE,x,does,varb
  2567.     cfas    const
  2568.     scode
  2569. varcode    addq.l    #4,d6
  2570.     move.l    d6,-(SP)
  2571.     gonext
  2572. *
  2573.     dcode    OBJMP,x,varb,objmp
  2574.     move.l    #(obcode-origin),d0    ; get addr of object code
  2575.     jmp    0(a3,d0.l)    ; obj puts its addr on stack
  2576. *
  2577.     dcol    (AB"),x,objmp,abq_    ; abort" runtime word
  2578.     cfas    mindup
  2579.     eif.    abq11
  2580.     cfas    cr,lit,10+origin,beep,here,count,type
  2581.     cfas    lit,63+origin,emit,space,R,count,type,abort
  2582.     else.    abq11
  2583.     cfas    rfrom,count,plus,aline,tor
  2584.     ethen.    abq11
  2585.     cfas    semis
  2586. *
  2587.     dcol    PREFIX,x,abq_,prefix    ; prefix builder for mcfa
  2588.     cfas    builds,times4,wcomma,immed
  2589.     cfas    does
  2590. dopref    cfas    fetpfa
  2591.     cfas    cfa,over,wfetch,plus
  2592.     cfas    swap_,min4,over,fetch,lit,6+origin,subt
  2593.     cfas    fetch,subt,abq_
  2594.     STR    "invalid prefix "
  2595.     cfas    state
  2596.     if.    pre11
  2597.     cfas    comma,semis
  2598.     then.    pre11
  2599.     cfas    exec,semis
  2600. *
  2601. ; execute 1cfa of object vector ivar
  2602.     dcode    X1CFA,x,prefix,x1cfa
  2603.     move.l    d5,a2    ; 1cfa is the fetch/deferred exec routine
  2604.     clr.l    d6
  2605.     move.w    (a4)+,d6    ; get offset to ivar
  2606.     add.l    (a2),d6    ; add base addr to get 1cfa addr in WP
  2607.     move.l    0(a3,d6.l),d7    ; get code addr in d7
  2608.     jmp    0(a3,d7.l)
  2609. *
  2610.     dcol    VOCABULARY,x,x1cfa,vocab
  2611.     cfas    builds
  2612.     mlit    $8120
  2613.     cfas    wcomma,currnt,min2,comma,here,vocl,comma
  2614.     cfas    vocl2,does
  2615. dovocab    cfas    plus2,contxt2,semis
  2616. *
  2617. ; define prefixes for 3cfa variables,vects
  2618.     ddoes    PUT,I,vocab,preput,dopref    ; 2cfa for all
  2619.     DC.W    8
  2620.     ddoes    PUTDEF,I,preput,prputd,dopref    ; 1cfa for sysVe
  2621.     DC.W    4
  2622. ; define code handlers for 3cfa variables,vects
  2623.     DATA    0    ; fetch code for sysvect
  2624.     DC.W    8    ; len to vect's pfa from 1cfa
  2625. dofetchv    addq.l    #8,d6    ; advance wp to pfa
  2626.     move.l    0(a3,d6.l),-(SP)    ; get contents of pfa
  2627.     gonext
  2628. *
  2629.     DATA    preput+4-origin    ; store code
  2630.     DC.W    4    ; len to vect's pfa from 1cfa
  2631. dostore    addq.l    #4,d6    ; advance wp to pfa
  2632.     move.l    (SP)+,0(a3,d6.l)    ; get contents of pfa
  2633.     gonext
  2634. *
  2635.     DATA    0    ; increment code
  2636.     DC.W    8    ; len to vect's pfa from 1cfa
  2637. doincr    addq.l    #8,d6    ; advance wp to pfa
  2638.     popd0
  2639.     add.l    d0,0(a3,d6.l)    ; increment contents of pfa
  2640.     gonext
  2641. *
  2642.     DC.W    12
  2643. doexec    add.l    #12,d6
  2644.     move.l    0(a3,d6.l),d6    ; get address to execute
  2645.     move.l    0(a3,d6.l),d7    ; get contents of CFA
  2646.     jmp    0(a3,d7.l)    ; execute the code
  2647.     DC.W    12    ; execute a system vector table entry
  2648. dosexec    add.l    #12,d6
  2649.     move.l    userdp(PC),d0    ; rel base of system vector table
  2650.     add.l    0(a3,d6.l),d0    ; add offset into table
  2651.     move.l    0(a3,d0.l),d1    ; get vector contents
  2652.     beq    dodeflt    ; if 0, exec default
  2653.     move.l    d1,d6
  2654.     bra.s    sexec
  2655. dodeflt    move.l    4(a3,d6.l),d6    ; get default cfa to execute
  2656. sexec    move.l    0(a3,d6.l),d7    ; get contents of CFA
  2657.     jmp    0(a3,d7.l)    ; execute the code
  2658. *
  2659.     DATA    prputd+4-origin
  2660.     DC.W    8    ; set offset, default for system vector
  2661. doputdef    addq.l    #8,d6
  2662.     move.l    (SP)+,0(a3,d6.l)    ; set the offset
  2663.     move.l    (SP)+,4(a3,d6.l)    ; set the default
  2664.     gonext
  2665. *
  2666.     DATA    preput+4-origin
  2667.     DC.W    4    ; set sys vector table entry for this vect
  2668. doputsv    addq.l    #4,d6
  2669.     move.l    userdp(PC),d0
  2670.     add.l    0(a3,d6.l),d0    ; add the offset
  2671.     move.l    (SP)+,0(a3,d0.l)    ; store the vector
  2672.     gonext
  2673. *
  2674.     DC.W    12    ; len to value's pfa from 1cfa
  2675. dofetch    add.l    #12,d6    ; advance wp to pfa
  2676.     move.l    0(a3,d6.l),-(SP)    ; get contents of pfa
  2677.     gonext
  2678. *
  2679.     dcol    ",",x,prputd,comma    ; begin comman dict entry
  2680.     cfas    here,store,pfour,allot,semis
  2681. *
  2682.     dcol    "W,",x,comma,wcomma    ; begin Wcomma dict entry
  2683.     cfas    here,wstore,lit,2+origin,allot,semis
  2684. *
  2685.     dcol    "C,",x,wcomma,ccomma    ; begin C, dict entry
  2686.     cfas    here,cstore,pone,allot,semis
  2687. *
  2688.     dcol    @PFA,x,ccomma,fetpfa
  2689.     cfas    mfind,zequ,abq_
  2690.     STR    "not found  "
  2691.     cfas    drop,semis
  2692. *
  2693.     dcol    LFA,x,fetpfa,lfa
  2694.     mlit    8
  2695.     cfas    subt,semis
  2696. *
  2697.     dcol    NFA,x,lfa,nfa
  2698.     mlit    9
  2699.     cfas    subt
  2700.     mlit    -1
  2701.     cfas    traver,semis
  2702. *
  2703.     dcol    PFA,x,nfa,pfa
  2704.     mlit    1
  2705.     cfas    traver,lit,9+origin,plus,semis
  2706. *
  2707.     dcol    >LINE,x,pfa,toline
  2708.     cfas    docs
  2709.     if.    L100
  2710.     cfas    min2
  2711.     then.    L100
  2712.     cfas    semis
  2713. *
  2714.     dcol    LINE>,x,toline,linefm
  2715.     cfas    docs
  2716.     if.    L101
  2717.     cfas    plus2
  2718.     then.    L101
  2719.     cfas    semis
  2720. *
  2721.     dcol    ALIGN,x,linefm,aline
  2722.     cfas    dup
  2723.     mlit    1
  2724.     cfas    and_,plus,semis
  2725. *
  2726.     dcol    DECIMAL,x,aline,decim
  2727.     mlit    $0a
  2728.     cfas    base2,semis
  2729. *
  2730.     dcol    HEX,x,decim,hex
  2731.     mlit    $10
  2732.     cfas    base2,semis
  2733. *
  2734.     dcol    (."),x,hex,dotq_
  2735.     cfas    r,count,dup,plus1,aline,rfrom,plus,toR,type
  2736.     cfas    semis
  2737. *
  2738.     dcol    PAD,x,dotq_,pad
  2739.     mlit    padbuf-origin
  2740.     cfas    semis
  2741. *
  2742.     dcol    #>,x,pad,enum
  2743.     cfas    drop2,hld,pad,over,subt,semis
  2744. *
  2745.     dcol    HOLD,x,enum,hold
  2746.     DATA    pmone-origin
  2747.     cfas    hld1,hld,cstore,semis
  2748. *
  2749.     dcol    SIGN,x,hold,sign
  2750.     cfas    rot,zless
  2751.     if.    Z3
  2752.     mlit    $2d
  2753.     cfas    hold
  2754.     then.    Z3
  2755.     cfas    semis
  2756. *
  2757.     dcol    #,x,sign,sharp
  2758.     cfas    base,msmod,rot
  2759.     mlit    9
  2760.     cfas    over,less
  2761.     if.    Z4
  2762.     mlit    7
  2763.     cfas    plus
  2764.     then.    Z4
  2765.     mlit    $30
  2766.     cfas    plus,hold,semis
  2767. *
  2768.     dcol    #S,x,sharp,sharps
  2769.     begin.    Z5
  2770.     cfas    sharp,dup2,or_,zequ
  2771.     until.    Z5
  2772.     cfas    semis
  2773. *
  2774.     dcol    <#,x,sharps,snum
  2775.     cfas    pad,hld2,semis
  2776. *
  2777.     dcol    D.R,x,snum,ddotr
  2778.     cfas    toR,swap_,over,dabs,snum,sharps,sign,enum,rfrom
  2779.     cfas    over,subt,spaces,type,semis
  2780. *
  2781.     dcol    D.,x,ddotr,ddot
  2782.     mlit    0
  2783.     cfas    ddotr,space,semis
  2784. *
  2785.     dcol    .,x,ddot,dot
  2786.     cfas    sToD,ddot,semis
  2787. *
  2788.     dcol    U.,x,dot,udot
  2789.     mlit    0
  2790.     cfas    ddot,semis
  2791. *
  2792.     dcol    .R,x,udot,dotR
  2793.     cfas    toR,sToD,rfrom,ddotr,semis
  2794. *
  2795.     dcol    ?,x,dotR,quest
  2796.     cfas    fetch,dot,semis
  2797. *
  2798.     dcol    SPACE,x,quest,space
  2799.     cfas    bl,emit,semis
  2800. *
  2801.     dcol    SPACES,x,space,spaces
  2802.     mlit    0
  2803.     do.    Z7
  2804.     cfas    bl,emit
  2805.     loop.    Z7
  2806.     cfas    semis
  2807. *
  2808.     dcol    -TRAILING,x,spaces,mtrail
  2809.     cfas    dup
  2810.     mlit    0
  2811.     do.    Z8
  2812.     cfas    over,over,plus,min1,cfetch,bl,subt
  2813.     eif.    Z10
  2814.     cfas    leave
  2815.     else.    Z10
  2816.     cfas    min1
  2817.     ethen.    Z10
  2818.     loop.    Z8
  2819.     cfas    semis
  2820. *
  2821.     dcol    N>COUNT,x,mtrail,ncount
  2822.     cfas    count
  2823.     mlit    $1f
  2824.     cfas    and_,semis
  2825. *
  2826.     dcol    ID.,x,ncount,iddot
  2827.     cfas    ncount,type,space,semis
  2828. *
  2829.     dcol    EMIT,x,iddot,emit
  2830.     cfas    dup,emitvec,pemitv,pone     ; send the char via Quickdraw
  2831.     cfas    out1,semis
  2832. *
  2833.     dcol    TYPE,x,emit,type
  2834.     cfas    dup,out1,dup2,typevec,ptypev,semis
  2835.     dcol    CR,x,type,cr
  2836.     cfas    crvec,pcrvec,semis
  2837. *
  2838.     dcol    CONTBOT,x,cr,contbot
  2839.     cfas    port_,lit,windowsize+origin,plus,plus4
  2840.     cfas    wfetch,semis
  2841. *
  2842.     dcol    CONTTOP,x,contbot,conttop
  2843.     cfas    port_,lit,windowsize+origin,plus
  2844.     cfas    wfetch,semis
  2845. *
  2846.     dcol    ?LEAD,x,conttop,qlead    ; return proper leading for fo
  2847.     cfas    port_,lit,txsize+origin,plus,wfetch
  2848.     cfas    lit,120+origin,star,lit,50+origin,plus    ; Increase 120 f
  2849.     cfas    lit,100+origin,slash,semis
  2850. *
  2851.     dcol    ?LINES,x,qlead,qlines    ; number of even lines in port
  2852.     cfas    qlead,contbot,conttop    ; bottom-top of content rgn
  2853.     cfas    subt,lit,5+origin,subt,    ; less first line location
  2854.     cfas    over,plus1,subt    ; minus ?LEAD+1
  2855.     cfas    swap_,slash,semis    ; divided by ?LEAD
  2856. *
  2857.     dcol    BOTTOM,x,qlines,scrbot    ; coordinate of screen bottom
  2858.     cfas    conttop,plus4,qlead,qlines,star,plus
  2859.     cfas    semis
  2860. *
  2861.     dcol    (CR),x,scrbot,cr_    ; simulate a CR in Quickdraw
  2862.     cfas    dotcur,fetxy,swap_,drop,lit,8+origin,swap_
  2863.     cfas    dup,scrbot,grt
  2864.     eif.    x27
  2865.     cfas    pzer,qlead,minus,scroll,gotoxy
  2866.     else.    x27
  2867.     cfas    qlead,plus
  2868.     cfas    gotoxy
  2869.     ethen.    x27
  2870.     cfas    dotcur,semis
  2871. *
  2872.     dcol    (BS),x,cr_,bs_
  2873.     cfas    dotcur,fetxy,swap_,lit,6+origin,subt,lit,8+origin,max
  2874.     cfas    swap_,dup2,gotoxy,curs_,pzer,curs_2
  2875.     cfas    bl,emit,curs_2,gotoxy,dotcur,semis
  2876. *
  2877.     dcol    ?TERMINAL,x,bs_,qterm
  2878.     cfas    lit,$28+origin,qevt,semis
  2879. *
  2880.     dcol    (KEY),x,qterm,key_
  2881.     mlit    $2A        ; kbd and mouse events
  2882.     cfas    getevt,lit,2+origin,grt
  2883.     eif.    Z100
  2884.     cfas    ftemsg,lit,$00ff+origin,and_
  2885.     else.    Z100
  2886.     cfas    pmone
  2887.     ethen.    Z100
  2888.     cfas    semis
  2889. *
  2890.     dcol    (DKEY),x,key_,dkey_
  2891.     cfas    ufcb,pone,lit,ftwork    ; read 1 char from disk
  2892.     cfas    read_,dup,dkerr2
  2893.     eif.    y10
  2894.     cfas    keystor,pone,curs_2    ; restore to terminal if err
  2895.     cfas    lit,13+origin
  2896.     else.    y10
  2897.     cfas    lit,ftwork,cfetch    ; leav char on stack
  2898.     ethen.    y10
  2899.     cfas    qpause,semis
  2900. *
  2901.     dcol    KEY!,x,dkey_,keystor    ; reset KEY to keyboard
  2902.     cfas    lit,key_,keyvec2,semis
  2903. *
  2904.     dcol    KEY,x,keystor,key
  2905.     cfas    keyvec,semis    ; vectored key
  2906. *
  2907.     dcol    <",x,key,diskin    ; set to disk key inpu
  2908.     cfas    ufcb,close_,dot    ; close the oldfile
  2909.     cfas    lit,useFcb,lit,80+origin,era,pzer,curs_2
  2910.     cfas    lit,34+origin,word,here,dup,cfetch,plus1
  2911.     cfas    lit,useFname,swap_,cmove
  2912.     cfas    lit,useFname,basadr,lit,useFcb,sflptr
  2913.     cfas    ufcb,pone,open_,dot
  2914.     cfas    cr,lit,dkey_,keyvec2,semis
  2915. *
  2916. ; ------------ Disk words for FORTH screen handling
  2917.     dcol    !FPTR,x,diskin,sflptr    ; ( ^fname pblock -- )
  2918.     cfas    lit,18+origin,plus,store,semis
  2919. *
  2920.     dcol    ?COMP,x,sflptr,qcomp
  2921.     cfas    state,zequ,abq_
  2922.     STR    "compilation only "
  2923.     cfas    semis
  2924. *
  2925.     dcol    ?DP,x,qcomp,qdp    ; dp grown into heap?
  2926.     cfas    room,pone,less,abq_
  2927.     STR    " out of room "
  2928.     cfas    semis
  2929. *
  2930.     dcol    ?STACK,x,qdp,qstack
  2931.     cfas    spfet,s0,swap_,uless
  2932.     cfas    abq_
  2933.     STR    "empty stack  "
  2934.     cfas    semis
  2935. *
  2936.     dcol    ?EXEC,x,qstack,qexec
  2937.     cfas    state,cstate,or_,abq_    ; err if class or forth compile
  2938.     STR    "run state only "
  2939.     cfas    semis
  2940. *
  2941.     dcol    ?PAIRS,x,qexec,qpairs
  2942.     cfas    subt,abq_
  2943.     STR    "unpaired conditionals  "
  2944.     cfas    semis
  2945. *
  2946.     dcol    ?CSP,x,qpairs,qcsp
  2947.     cfas    spfet,csp,subt,abq_
  2948.     STR    "definition not finished  "
  2949.     cfas    semis
  2950. *
  2951.     dcol    (NUMBER),x,qcsp,num_
  2952.     begin.    Z27
  2953.     cfas    plus1,dup,tor,cfetch,base,digit
  2954.     while.    Z27
  2955.     cfas    swap_,base,ustar,drop,rot,base
  2956.     cfas    ustar,dplus,dpl,plus1
  2957.     if.    Z28
  2958.     cfas    pone,dpl1
  2959.     then.    Z28
  2960.     cfas    rfrom
  2961.     repeat.    Z27
  2962.     cfas    rfrom,semis
  2963. *
  2964.     dcol    ?NUM,x,num_,qnum    ; ( addr -- d t OR f )
  2965.     cfas    pzer,pzer,rot,dup,plus1,cfetch
  2966.     mlit    $2d
  2967.     cfas    equals,dup,tor,plus,pmone
  2968.     begin.    Z30
  2969.     cfas    dpl2,num_,dup,cfetch,bl,subt
  2970.     while.    Z30
  2971.     cfas    dup,cfetch,lit,$2e+origin,subt
  2972.     if.    zz177
  2973.     cfas    rfrom,drop2,drop2,pzer,semis
  2974.     then.    zz177
  2975.     cfas    pzer
  2976.     repeat.    Z30
  2977.     cfas    drop,rfrom
  2978.     if.    Z31
  2979.     cfas    dminus
  2980.     then.    Z31
  2981.     cfas    pone,semis
  2982. *
  2983.     dcol    NUMBER,x,qnum,number    ; ( addr -- d )
  2984.     cfas    qnum,zequ,abq_
  2985.     STR    "not found  "
  2986.     cfas    semis
  2987. *
  2988.     dcol    LITERAL,I,number,liter
  2989.     cfas    state
  2990.     if.    Z32
  2991.     cfas    dup,lit
  2992.     DATA    $10000
  2993.     cfas    less,over,zless,zequ,and_
  2994.     eif.    zz39
  2995.     cfas    comp,wlit,wcomma
  2996.     else.    zz39
  2997.     cfas    comp,lit,comma    ; builds word lit if n>=0 and n<$10000
  2998.     ethen.    zz39
  2999.     then.    Z32
  3000.     cfas    semis
  3001. *
  3002.     dcol    EXPECT,x,liter,expect
  3003.     cfas    over,plus,over
  3004.     do.    Z33
  3005.     cfas    key,dup,lit,8+origin,equals    ; bs ?
  3006.     eif.    Z34
  3007.     cfas    drop,dup,i,equals,dup,rfrom,min2,plus,tor
  3008.     eif.    Z35
  3009.     cfas    lit,10+origin,beep
  3010.     else.    Z35
  3011.     cfas    bs_
  3012.     ethen.    Z35
  3013.     cfas    pzer
  3014.     else.    Z34
  3015.     cfas    dup,zequ
  3016.     if.    y118
  3017.     cfas    drop,lit,32+origin    ; map null to space
  3018.     then.    y118
  3019.     cfas    dup,lit,$0d+origin,equals
  3020.     eif.    Z36
  3021.     cfas    leave,drop,pzer,pzer,cr
  3022.     else.    Z36
  3023.     cfas    dup
  3024.     ethen.    Z36
  3025.     cfas    r,cstore,pzer,r,plus1,cstore
  3026.     ethen.    Z34
  3027.     cfas    echovec
  3028.     loop.    Z33
  3029.     cfas    drop,semis
  3030. *
  3031.     dcol    WORD,x,expect,word
  3032.     cfas    tib
  3033.     cfas    in,plus,swap_,enclos
  3034.     cfas    word_,semis
  3035. *
  3036.     dcol    WORD",x,word,wordq    ; lower-case version of word
  3037.     cfas    tib,in,plus,lit,34+origin,enclos
  3038.     cfas    lcword,here,semis
  3039. *
  3040.     dcol    FIND,x,wordq,mfind
  3041.     cfas    bl,word,ufind,dup,zequ
  3042.     if.    w72
  3043.     cfas    drop,here,contxt,fetch
  3044.     cfas    find_,dup,zequ
  3045.     if.    Z38
  3046.     cfas    contxt,currnt,subt
  3047.     if.    Z40
  3048.     cfas    drop,here,latest,find_
  3049.     then.    Z40
  3050.     then.    Z38
  3051.     then.    w72
  3052.     cfas    semis
  3053. *
  3054.     ADJST        ; X - null word
  3055. lkx    DC.B    $C1
  3056.     DC.B    $00
  3057.     DATA    lkmfind-origin
  3058.     DATA    colcode-origin    ; not Fig standard -
  3059.     cfas    rfrom,drop    ; note: doesn't support Forth screens
  3060.     cfas    semis
  3061. *
  3062.     dcol    "S,",x,x,scomma    ; begin S, dict entry
  3063.     cfas    here,dup,cfetch,plus1,dup
  3064.     cfas    allot,pone,and_
  3065.     if.    sc10
  3066.     cfas    pzer,ccomma
  3067.     then.    sc10
  3068.     cfas    dup,rot,toggle,semis
  3069. *
  3070.     dcol    (CREATE),x,scomma,creat_
  3071.     cfas    here,pone,and_
  3072.     if.    Z430
  3073.     cfas    pzer,ccomma
  3074.     then.    Z430
  3075.     cfas    docs
  3076.     if.    Z410
  3077.     cfas    line_,wcomma
  3078.     then.    Z410
  3079.     cfas    mfind
  3080.     if.    Z420
  3081.     cfas    drop,nfa,iddot,dotq_
  3082.     STR    "is redefined "
  3083.     cfas    cr
  3084.     then.    Z420
  3085.     cfas    lit,$80+origin,scomma
  3086.     cfas    latest,comma,currnt
  3087.     cfas    store,here,plus4,comma,semis
  3088. *
  3089.     dcol    (INTRP),x,creat_,intrp_
  3090.     begin.    Z43
  3091.     cfas    mfind
  3092.     eif.    Z44
  3093.     cfas    state,less
  3094.     eif.    Z45
  3095.     cfas    cfa,comma
  3096.     else.    Z45
  3097.     cfas    cfa,exec
  3098.     ethen.    Z45
  3099.     else.    Z44
  3100.     cfas    here,number,dpl,plus1
  3101.     eif.    Z46
  3102.     cfas    dliter
  3103.     else.    Z46
  3104.     cfas    drop,liter
  3105.     ethen.    Z46
  3106.     ethen.    Z44
  3107.     cfas    qdp,qstack
  3108.     again.    Z43
  3109.     cfas    semis
  3110. *
  3111.     dcol    !CSP,x,intrp_,stcsp
  3112.     cfas    spfet,csp2,semis
  3113. *
  3114.     dcol    QUERY,x,stcsp,query
  3115.     cfas    tib,lit,$99+origin
  3116.     cfas    expvec,pzer,in2,semis
  3117. *
  3118.     dcol    <[,I,query,lbrak
  3119.     mlit    0
  3120.     cfas    state2,semis
  3121. *
  3122.     dcol    ]>,x,lbrak,rbrak
  3123.     mlit    $c0
  3124.     cfas    state2,semis
  3125. *
  3126.     dcol    DEFINITIONS,x,rbrak,defs
  3127.     cfas    contxt,currnt2,semis
  3128. *
  3129.     dcol    <BUILDS,x,defs,builds
  3130.     mlit    0
  3131.     cfas    const,semis
  3132. *
  3133.     dcol    OK,x,builds,ok
  3134.     cfas    depth,ptwo,dotr,base,dup
  3135.     cfas    lit,10+origin,equals
  3136.     eif.    xx11
  3137.     cfas    lit,45+origin,emit
  3138.     else.    xx11
  3139.     cfas    dup,lit,16+origin,equals
  3140.     eif.    xx12
  3141.     cfas    lit,36+origin,emit
  3142.     else.    xx12
  3143.     cfas    lit,63+origin,emit
  3144.     ethen.    xx12
  3145.     ethen.    xx11
  3146.     cfas    drop,lit,62+origin,emit
  3147.     cfas    semis
  3148. *
  3149.     dcode    Q,x,ok,q_
  3150.     clr.w    -(sp)
  3151.     _hilitemenu
  3152.     gonext
  3153. *
  3154.     dcol    QUIT,x,ok,quit
  3155.     cfas    pzer,in2
  3156.     cfas    lbrak,quvec,q_
  3157.     cfas    cr,ok
  3158.     begin.    Z48
  3159.     cfas    qdp,rpstor,query,interp,state,zequ
  3160.     if.    Z50
  3161.     cfas    ok
  3162.     then.    Z50
  3163.     again.    Z48
  3164.     cfas    semis
  3165. *
  3166.     dcol    BACK,x,quit,back
  3167.     cfas    here,subt,comma,semis
  3168. *
  3169.     dcol    FWD,x,back,fwd    ; fill in fwd branch
  3170.     cfas    here,over,subt,swap_,store,semis
  3171. *
  3172.     dcol    BEGIN,I,fwd,begin
  3173.     cfas    qcomp,here,pone,semis
  3174. *
  3175.     dcol    THEN,I,begin,then
  3176.     cfas    qcomp,lit,2+origin,qpairs,fwd,semis
  3177. *
  3178.     dcol    DO,I,then,do    ; compiles fwd branch for smart exit
  3179.     cfas    comp,do_,here,pzer,comma,lit,3+origin,semis
  3180. *
  3181.     dcol    LOOP,I,do,loop
  3182.     cfas    lit,3+origin,qpairs,comp,loop_,dup,plus4,back
  3183.     cfas    fwd,semis
  3184. *
  3185.     dcol    +LOOP,I,loop,ploop
  3186.     cfas    lit,3+origin,qpairs,comp,ploop_,dup,plus4,back
  3187.     cfas    fwd,semis
  3188. *
  3189.     dcol    COMPILE,x,ploop,comp
  3190.     cfas    qcomp,rfrom,dup,plus4
  3191.     cfas    tor,fetch,comma,semis
  3192.     dcol    [COMPILE],I,comp,bcomp
  3193.     cfas    fetpfa,cfa,comma,semis
  3194. *
  3195.     dcol    DLITERAL,I,bcomp,dliter
  3196.     cfas    state
  3197.     if.    Z51
  3198.     cfas    swap_,liter,liter
  3199.     then.    Z51
  3200.     cfas    semis
  3201. *
  3202.     dcol    UNTIL,I,dliter,until
  3203.     cfas    pone,qpairs,comp,bran0,back,semis
  3204. *
  3205.     dcol    AGAIN,I,until,again
  3206.     cfas    pone,qpairs,comp,bran,back,semis
  3207. *
  3208.     dcol    REPEAT,I,again,repeat
  3209.     cfas    tor,tor,again,rfrom,rfrom,min2
  3210.     cfas    then,semis
  3211. *
  3212.     dcol    IF,I,repeat,xif
  3213.     cfas    comp,bran0,here,pzer,comma,lit,2+origin,semis
  3214. *
  3215.     dcol    ELSE,I,xif,xelse
  3216.     cfas    lit,2+origin,qpairs,comp,bran,here,pzer,comma
  3217.     cfas    swap_,lit,2+origin,then,lit,2+origin,semis
  3218. *
  3219.     dcol    WHILE,I,xelse,while
  3220.     cfas    xif,plus2,semis
  3221. *
  3222.     dcol    EXIT,I,while,exit
  3223.     cfas    latest,pfa,cfa,fetch    ; is this a pcolon def?
  3224.     cfas    lit,pcolcode,equals
  3225.     eif.    se10
  3226.     cfas    comp,semip    ; yes, put in parm denester
  3227.     else.    se10
  3228.     cfas    comp,semis
  3229.     ethen.    se10
  3230.     cfas    semis
  3231. *
  3232.     dcol    ;,I,exit,semi    ; immediate - semicolon def
  3233.     cfas    qcsp,exit,lbrak,semis
  3234. *
  3235.     dcol    .",I,semi,dotq
  3236.     cfas    state
  3237.     eif.    Z52
  3238.     cfas    comp,dotq_
  3239.     cfas    wordq    ; lower-case word
  3240.     cfas    cfetch,plus1,aline,allot
  3241.     else.    Z52
  3242.     cfas    wordq,count,type
  3243.     ethen.    Z52
  3244.     cfas    semis
  3245. *
  3246.     dcol    IMMEDIATE,x,dotq,immed
  3247.     cfas    latest,lit,$40+origin,toggle,semis
  3248. *
  3249.     dcol    LATEST,x,immed,latest
  3250.     cfas    currnt,fetch,semis
  3251. *
  3252.     dcol    (,I,latest,lparen
  3253.     cfas    lit,$29+origin,word,semis
  3254. *
  3255.     ADJST    
  3256. lktick    DC.B    $c1    ; tick
  3257.     DC.B    $27
  3258.     DATA    lklparen-origin
  3259. tick    DATA    colcode-origin
  3260.     cfas    fetpfa,liter,semis
  3261. *
  3262.     dcol    FORGET,x,tick,forget
  3263.     cfas    defs    ; set current to context
  3264.     cfas    tick,dup,fence,uless,abq_
  3265.     STR    "in protected dictionary  "
  3266.     cfas    dup,nfa,dp2,lfa,fetch,currnt    ; leave line# if sources on
  3267.     cfas    store,semis    ; otherwise might forget nec stuff
  3268. *
  3269.     dcol    ROOM,x,forget,room    ; leave dict space left
  3270.     cfas    msiz,fetch,dp,bdp,fetch
  3271.     cfas    subt,subt,semis
  3272. *
  3273.     dcol    GREET,x,room,greet
  3274.     cfas    cls
  3275.     mlit    hello-origin
  3276.     cfas    count,type,cr
  3277.     mlit    bytesleft-origin
  3278.     cfas    count,type
  3279.     cfas    room,dot,cr,semis
  3280. *
  3281.     dcol    COLD,x,greet,xcold
  3282.     cfas    lit,aregn,fetch,zequ
  3283.     if.    w59
  3284.     cfas    intool    ; only if we haven't gotten heap already
  3285.     then.    w59
  3286.     cfas    lit,inits0,fetch,s02,lit,initr0,fetch,r02
  3287.     cfas    lit,initfenc,fetch,fence2,lit,initvocl,fetch,vocl2
  3288.     cfas    lit,initdp,fetch,dp2,lit,initmp,fetch,m02
  3289.     cfas    lit,initlast,fetch,lit,forth_
  3290.     cfas    lit,$0a+origin,plus,store,decim,spstor,mpstor    \ careful on the 0a
  3291.     cfas    forth_,defs,pzer,warn2,objini,greet,quit,semis
  3292. *
  3293.     dcol    .PAUSE,x,xcold,dpause
  3294.     cfas    lit,pausemsg,count,type,semis
  3295. *
  3296.     dcol    ?PAUSE,x,dpause,qpause    ; check if user wants to stop
  3297.     cfas    qterm
  3298.     if.    w43
  3299.     cfas    key_,drop,cr,dpause
  3300.     cfas    key_,cr,lit,0+origin,out2,lit,32+origin,grt
  3301.     if.    w44
  3302.     cfas    abort
  3303.     then.    w44
  3304.     then.    w43
  3305.     cfas    semis
  3306. *
  3307.     dcol    ABORT,x,qpause,abort
  3308.     cfas    cr
  3309.     cfas    spstor,mpstor,lit,key_,keyvec2,decim
  3310.     cfas    pone,curs_2,qstack,lbrak,forth_
  3311.     cfas    defs,abvec
  3312.     cfas    lit,$a850+origin,trap_    ; initCursor
  3313.     cfas    quit,semis
  3314. *
  3315.     ddoes    YERK,x,abort,forth_,dovocab    ; FORTH vocabulary
  3316.     DC.W    $8120
  3317. vlf    DATA    lastdef-origin
  3318.     DATA    0
  3319. *
  3320.     dcol    .VAL,x,forth_,dotval
  3321.     cfas    dotr,lit,2+origin,spaces,semis
  3322. *
  3323.     dcol    ?CFA,x,dotval,qcfa
  3324.     cfas    dup,plus4,nfa,ncount
  3325.     cfas    tor,r,plus,plus4,aline
  3326.     cfas    over,equals,rfrom,land_,semis
  3327. *
  3328.     dcol    (.STACK),x,qcfa,dstak_
  3329.     cfas    base,lit,ftwork1,store,dup2,grt    ; preserve current base
  3330.     eif.    z61
  3331.     do.    z62
  3332.     cfas    cr,ifetch,dup,decim
  3333.     cfas    lit,8+origin,dotval,dup,hex,lit,36+origin,emit
  3334.     cfas    pzer,lit,6+origin,ddotr
  3335.     cfas    lit,3+origin,spaces,aline,min4,plus1,false
  3336.     eif.    z63
  3337.     cfas    plus4,nfa,iddot
  3338.     else.    z63
  3339.     cfas    drop
  3340.     ethen.    z63
  3341.     cfas    pfour
  3342.     ploop.    z62
  3343.     else.    z61
  3344.     cfas    lit,emptymsg,count,type,less
  3345.     cfas    abq_
  3346.     STR    "Stack Underflow  "
  3347.     ethen.    z61
  3348.     cfas    lit,ftwork1,fetch,base2,cr    restore base
  3349.     cfas    semis
  3350. *
  3351. Lastdef    dcol    .S,x,dstak_,dots
  3352.     cfas    spfet,s0,swap_,lit,dsmsg
  3353.     cfas    count,type,dstak_,r0,rpfet,lit,rsmsg
  3354.     cfas    count,type,dstak_,m0,mpfet,lit,msmsg
  3355.     cfas    count,type,dstak_
  3356.     cfas    semis
  3357. *
  3358. nextdef    EQU    *
  3359.     ENDR
  3360. *
  3361.     SEG    0,32,VAR.LEN,$20
  3362. SEG0
  3363. SEG_1    JP    start,1
  3364.     JP    getInstL,1
  3365. END_1
  3366. SEG_2    JP    origin,2
  3367.     JP    coldvec,2
  3368.     JP    getDict,2
  3369. END_2
  3370. END0
  3371.     ENDR
  3372. *
  3373. *    END
  3374.     RSRC    YERK,0,32
  3375.     STR     "Yerk Version 3.6.6"
  3376.     ENDR
  3377. *
  3378.     RSRC    FREF,128,32
  3379.     ASC    'APPL'
  3380.     DATA    /0
  3381.     STR    ""
  3382.     ENDR
  3383. *
  3384.     RSRC    FREF,129,32
  3385.     ASC    'COM '
  3386.     DATA    /1
  3387.     STR    ""
  3388.     ENDR
  3389. *
  3390.     RSRC    FREF,130,32
  3391.     ASC 'USER'
  3392.     DATA /2
  3393.     STR    ""
  3394.     ENDR
  3395. *
  3396.     RSRC    FREF,131,32
  3397.     ASC    'BIN '
  3398.     DATA /3
  3399.     STR    ""
  3400.     ENDR
  3401. *
  3402.     RSRC    FREF,132,32
  3403.     ASC    'TEXT'
  3404.     DATA /4
  3405.     STR    ""
  3406.     ENDR
  3407. *
  3408.     RSRC    ICN#,128,32
  3409.     HEX    71c0.0000.cb20.0000
  3410.     HEX    c620.0000.6040.0000
  3411.     HEX    3080.0000.1900.1f80
  3412.     HEX    1900.2040.197e.4020
  3413.     HEX    1981.9810.1e8e.e408
  3414.     HEX    0ccf.3f87.3069.1803
  3415.     HEX    c864.8003.c864.4003
  3416.     HEX    c8c8.f003.c99f.8ff3
  3417.     HEX    c981.990f.c9ff.9903
  3418.     HEX    c8fd.8200.c801.8400
  3419.     HEX    c801.8200.c801.91ce
  3420.     HEX    c801.9939.c801.9f32
  3421.     HEX    c801.d724.c800.e308
  3422.     HEX    c800.0304.cfff.e322
  3423.     HEX    c000.1331.c000.1339
  3424.     HEX    ffff.e3ef.7fff.c1c6
  3425. *
  3426.     HEX    71c0.0000.fbe0.0000
  3427.     HEX    ffe0.0000.7fc0.0000
  3428.     HEX    3f80.0000.1f00.1f80
  3429.     HEX    1f00.3fc0.1f7e.7fe0
  3430.     HEX    1fff.fff0.1ffe.e7f8
  3431.     HEX    0fff.ffff.3ff9.ffff
  3432.     HEX    fffc.ffff.fffc.7fff
  3433.     HEX    fff8.ffff.ffff.ffff
  3434.     HEX    ffff.ff0f.ffff.ff03
  3435.     HEX    ffff.fe00.ffff.fc00
  3436.     HEX    ffff.fe00.ffff.ffce
  3437.     HEX    ffff.ffff.ffff.fffe
  3438.     HEX    ffff.fffc.ffff.fff8
  3439.     HEX    ffff.fffc.ffff.fffe
  3440.     HEX    ffff.ffff.ffff.c1ff
  3441.     HEX    ffff.c1ef.7fff.c1c6
  3442.     ENDR
  3443. *
  3444.     RSRC    ICN#,129,32
  3445.     HEX    71c7.fffe.cb2c.0001
  3446.     HEX    c62c.0001.604f.fff9
  3447.     HEX    3087.fff9.1900.0019
  3448.     HEX    1900.0019.197e.0019
  3449.     HEX    1981.0019.1e8e.0019
  3450.     HEX    0ccc.0019.3068.0019
  3451.     HEX    c864.0019.c864.0019
  3452.     HEX    c8c8.fc19.c99f.8219
  3453.     HEX    c981.9919.c9ff.9919
  3454.     HEX    c8fd.821f.c801.840e
  3455.     HEX    c801.8200.c801.91ce
  3456.     HEX    c801.9939.c801.9f32
  3457.     HEX    c801.d724.c800.e308
  3458.     HEX    c800.0304.cfff.e322
  3459.     HEX    c000.1331.c000.1339
  3460.     HEX    ffff.e3ef.7fff.c1c6
  3461. *
  3462.     HEX    71c7.fffe.fbef.ffff
  3463.     HEX    ffef.ffff.7fcf.ffff
  3464.     HEX    3fff.ffff.1fff.ffff
  3465.     HEX    1fff.ffff.1fff.ffff
  3466.     HEX    1fff.ffff.1fff.ffff
  3467.     HEX    0fff.ffff.3fff.ffff
  3468.     HEX    ffff.ffff.ffff.ffff
  3469.     HEX    ffff.ffff.ffff.ffff
  3470.     HEX    ffff.ffff.ffff.ffff
  3471.     HEX    ffff.ffff.ffff.ffff
  3472.     HEX    ffff.fff8.ffff.ffff
  3473.     HEX    ffff.ffff.ffff.ffff
  3474.     HEX    ffff.fffe.ffff.fffc
  3475.     HEX    ffff.fffc.ffff.fffe
  3476.     HEX    ffff.f3ff.ffff.f3ff
  3477.     HEX    ffff.e3ef.7fff.c1c6
  3478.     ENDR
  3479. *
  3480.     RSRC    ICN#,130,32
  3481.     HEX    71c7.fffe.cb2c.0001
  3482.     HEX    c62c.0001.604f.fff9
  3483.     HEX    3087.fff9.1900.0019
  3484.     HEX    1900.0019.1900.0019
  3485.     HEX    1900.0019.1e00.0019
  3486.     HEX    0c00.0019.3000.0019
  3487.     HEX    c800.0019.c800.0019
  3488.     HEX    c800.0019.c800.0019
  3489.     HEX    c800.0019.c800.0019
  3490.     HEX    c800.001f.c800.000f
  3491.     HEX    c800.0000.c800.01ce
  3492.     HEX    c800.0339.c800.0332
  3493.     HEX    c800.0324.c800.0308
  3494.     HEX    c800.0304.cfff.e322
  3495.     HEX    c000.1331.c000.1339
  3496.     HEX    ffff.e3cf.7fff.c1c6
  3497. *
  3498.     HEX    71c7.fffe.fbef.ffff
  3499.     HEX    ffef.ffff.7fff.ffff
  3500.     HEX    3fff.ffff.1fff.ffff
  3501.     HEX    1fff.ffff.1fff.ffff
  3502.     HEX    1fff.ffff.1fff.ffff
  3503.     HEX    0fff.ffff.3fff.ffff
  3504.     HEX    7fff.ffff.ffff.ffff
  3505.     HEX    ffff.ffff.ffff.ffff
  3506.     HEX    ffff.ffff.ffff.ffff
  3507.     HEX    ffff.ffff.ffff.ffff
  3508.     HEX    ffff.fffe.ffff.ffff
  3509.     HEX    ffff.ffff.ffff.ffff
  3510.     HEX    ffff.fffe.ffff.fffc
  3511.     HEX    ffff.fffc.ffff.fffe
  3512.     HEX    ffff.ffff.ffff.f3ff
  3513.     HEX    ffff.e3ef.7fff.c1c6
  3514.     ENDR
  3515. *
  3516.     RSRC    ICN#,131,32
  3517.     HEX    71c7.fffe.cb2c.0001
  3518.     HEX    c62c.0001.604f.fff9
  3519.     HEX    3087.fff9.1900.0019
  3520.     HEX    1900.0019.1900.0019
  3521.     HEX    1909.1899.1e09.2499
  3522.     HEX    0c09.2499.0009.1899
  3523.     HEX    7000.0019.c800.0019
  3524.     HEX    c989.2319.ca49.2499
  3525.     HEX    ca49.2499.c989.2319
  3526.     HEX    c800.001f.c800.000f
  3527.     HEX    c988.c000.ca49.21ce
  3528.     HEX    ca49.2339.c988.c332
  3529.     HEX    c800.0324.c800.0308
  3530.     HEX    c800.0304.cfff.f322
  3531.     HEX    c000.0b31.c000.0b39
  3532.     HEX    ffff.f3cf.7fff.e1c6
  3533. *
  3534.     HEX    71c7.fffe.fbef.ffff
  3535.     HEX    ffef.ffff.7fff.ffff
  3536.     HEX    3fff.ffff.1fff.ffff
  3537.     HEX    1fff.ffff.1fff.ffff
  3538.     HEX    1fff.ffff.1fff.ffff
  3539.     HEX    0fff.ffff.0fff.ffff
  3540.     HEX    7fff.ffff.ffff.ffff
  3541.     HEX    ffff.ffff.ffff.ffff
  3542.     HEX    ffff.ffff.ffff.ffff
  3543.     HEX    ffff.ffff.ffff.ffff
  3544.     HEX    ffff.fffe.ffff.ffff
  3545.     HEX    ffff.ffff.ffff.ffff
  3546.     HEX    ffff.fffe.ffff.fffc
  3547.     HEX    ffff.fffc.ffff.fffe
  3548.     HEX    ffff.ffff.ffff.ffff
  3549.     HEX    ffff.f7ff.7fff.e7ce
  3550.     ENDR
  3551. *
  3552.     RSRC    ICN#,132,32
  3553.     HEX    71c7.fffe.cb2c.0001
  3554.     HEX    c62c.0001.604f.fff9
  3555.     HEX    3087.fff9.1900.0019
  3556.     HEX    197f.0019.1900.0019
  3557.     HEX    190f.f019.1e00.0019
  3558.     HEX    0c0f.f019.0000.0019
  3559.     HEX    7001.fc19.c800.0019
  3560.     HEX    c87f.fc19.c800.0019
  3561.     HEX    c80f.8019.c800.0019
  3562.     HEX    c87f.fe19.c800.001f
  3563.     HEX    c80f.f000.c800.01ce
  3564.     HEX    c803.c339.c800.0332
  3565.     HEX    c8ff.c324.c800.0308
  3566.     HEX    c800.0304.cfff.e332
  3567.     HEX    c000.1339.c000.133d
  3568.     HEX    ffff.f3cf.7fff.e1c6
  3569. *
  3570.     HEX    638f.fffe.f7cf.ffff
  3571.     HEX    ffcf.ffff.7fff.ffff
  3572.     HEX    3fff.ffff.1fff.ffff
  3573.     HEX    1fff.ffff.1fff.ffff
  3574.     HEX    1fff.ffff.1fff.ffff
  3575.     HEX    1fff.ffff.7fff.ffff
  3576.     HEX    ffff.ffff.ffff.ffff
  3577.     HEX    ffff.ffff.ffff.ffff
  3578.     HEX    ffff.ffff.ffff.ffff
  3579.     HEX    ffff.ffff.ffff.ffff
  3580.     HEX    ffff.fffe.ffff.fffe
  3581.     HEX    ffff.fffe.ffff.fffe
  3582.     HEX    ffff.fffe.ffff.fffc
  3583.     HEX    ffff.fff8.ffff.fffc
  3584.     HEX    ffff.fffe.ffff.f3ff
  3585.     HEX    ffff.f3ee.7fff.f1c6
  3586.     ENDR
  3587. *
  3588.     RSRC    WIND,256
  3589.     DATA    /40,/2,/326,/498
  3590.     DATA    /8
  3591.     DATA    #1,#0
  3592.     DATA    #0,#0
  3593.     DATA    0
  3594.     STR    "yerk.com"
  3595.     ENDR
  3596. *
  3597.     RSRC    BNDL,128
  3598.     ASC    'YERK'
  3599.     DATA    /0
  3600.     DATA    /2-1
  3601.     ASC    'ICN#'
  3602.     DATA    /5-1
  3603.     DATA    /0,/128,/1,/129,/2,/130
  3604.     DATA    /3,/131,/4,/132
  3605.     ASC    'FREF'
  3606.     DATA    /5-1
  3607.     DATA    /0,/128,/1,/129,/2,/130
  3608.     DATA    /3,/131,/4,/132
  3609.     ENDR
  3610. *
  3611.     RSRC    SIZE,-1
  3612.     DATA    /$5880
  3613.     DATA    1022976
  3614.     DATA    393216
  3615.     ENDR
  3616. *
  3617.     RSRC    vers,1
  3618.     DATA    $03658000
  3619.     DATA    /0000
  3620.     STR    "3.6.6"
  3621.     STR    "3.6.6 Yerkes Observatory"
  3622.     ENDR
  3623. *
  3624.     END
  3625.